Mercurial > urweb

comparison src/monoize.sml @ 252:7e9bd70ad3ce

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Monoized and optimized initial query test
author Adam Chlipala <adamc@hcoop.net>
date Sun, 31 Aug 2008 13:58:47 -0400
parents 326fb4686f60
children 7f6620853c36
comparison
equal deleted inserted replaced
251:326fb4686f60 252:7e9bd70ad3ce
35 35
36 structure IM = IntBinaryMap 36 structure IM = IntBinaryMap
37 37
38 val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan) 38 val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan)
39 39
40 structure U = MonoUtil
41
42 val liftExpInExp =
43 U.Exp.mapB {typ = fn t => t,
44 exp = fn bound => fn e =>
45 case e of
46 L'.ERel xn =>
47 if xn < bound then
48 e
49 else
50 L'.ERel (xn + 1)
51 | _ => e,
52 bind = fn (bound, U.Exp.RelE _) => bound + 1
53 | (bound, _) => bound}
54
40 fun monoName env (all as (c, loc)) = 55 fun monoName env (all as (c, loc)) =
41 let 56 let
42 fun poly () = 57 fun poly () =
43 (E.errorAt loc "Unsupported name constructor"; 58 (E.errorAt loc "Unsupported name constructor";
44 Print.eprefaces' [("Constructor", CorePrint.p_con env all)]; 59 Print.eprefaces' [("Constructor", CorePrint.p_con env all)];
69 (L'.TFfi ("Basis", "string"), loc) 84 (L'.TFfi ("Basis", "string"), loc)
70 | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) => 85 | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) =>
71 (L'.TFfi ("Basis", "string"), loc) 86 (L'.TFfi ("Basis", "string"), loc)
72 87
73 | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) => 88 | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
74 (L'.TFun (mt env dtmap t, (L'.TRecord [], loc)), loc) 89 (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc)
90 | L.CApp ((L.CFfi ("Basis", "sql_table"), _), _) =>
91 (L'.TFfi ("Basis", "string"), loc)
92 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query"), _), _), _), _) =>
93 (L'.TFfi ("Basis", "string"), loc)
94 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query1"), _), _), _), _), _), _) =>
95 (L'.TFfi ("Basis", "string"), loc)
96 | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _) =>
97 (L'.TFfi ("Basis", "string"), loc)
98
99 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_subset"), _), _), _), _) =>
100 (L'.TRecord [], loc)
101 | L.CFfi ("Basis", "sql_relop") =>
102 (L'.TFfi ("Basis", "string"), loc)
103 | L.CFfi ("Basis", "sql_direction") =>
104 (L'.TFfi ("Basis", "string"), loc)
105 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_order_by"), _), _), _), _) =>
106 (L'.TFfi ("Basis", "string"), loc)
107 | L.CFfi ("Basis", "sql_limit") =>
108 (L'.TFfi ("Basis", "string"), loc)
109 | L.CFfi ("Basis", "sql_offset") =>
110 (L'.TFfi ("Basis", "string"), loc)
111
112 | L.CApp ((L.CFfi ("Basis", "sql_injectable"), _), t) =>
113 (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
114 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_unary"), _), _), _), _) =>
115 (L'.TFfi ("Basis", "string"), loc)
116 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_binary"), _), _), _), _), _), _) =>
117 (L'.TFfi ("Basis", "string"), loc)
118 | L.CFfi ("Basis", "sql_comparison") =>
119 (L'.TFfi ("Basis", "string"), loc)
120 | L.CApp ((L.CFfi ("Basis", "sql_aggregate"), _), t) =>
121 (L'.TFfi ("Basis", "string"), loc)
122 | L.CApp ((L.CFfi ("Basis", "sql_summable"), _), _) =>
123 (L'.TRecord [], loc)
124 | L.CApp ((L.CFfi ("Basis", "sql_maxable"), _), _) =>
125 (L'.TRecord [], loc)
75 126
76 | L.CRel _ => poly () 127 | L.CRel _ => poly ()
77 | L.CNamed n => 128 | L.CNamed n =>
78 (case IM.find (dtmap, n) of 129 (case IM.find (dtmap, n) of
79 SOME r => (L'.TDatatype (n, r), loc) 130 SOME r => (L'.TDatatype (n, r), loc)
345 | L.PCon (dk, pc, [], po) => (L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc) 396 | L.PCon (dk, pc, [], po) => (L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc)
346 | L.PCon _ => poly () 397 | L.PCon _ => poly ()
347 | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc) 398 | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc)
348 end 399 end
349 400
401 fun strcat loc es =
402 case es of
403 [] => (L'.EPrim (Prim.String ""), loc)
404 | [e] => e
405 | _ =>
406 let
407 val e2 = List.last es
408 val es = List.take (es, length es - 1)
409 val e1 = List.last es
410 val es = List.take (es, length es - 1)
411 in
412 foldr (fn (e, e') => (L'.EStrcat (e, e'), loc))
413 (L'.EStrcat (e1, e2), loc) es
414 end
415
416 fun strcatComma loc es =
417 case es of
418 [] => (L'.EPrim (Prim.String ""), loc)
419 | [e] => e
420 | _ =>
421 let
422 val e1 = List.last es
423 val es = List.take (es, length es - 1)
424 in
425 foldr (fn (e, e') =>
426 case e of
427 (L'.EPrim (Prim.String ""), _) => e'
428 | _ =>
429 (L'.EStrcat (e,
430 (L'.EStrcat ((L'.EPrim (Prim.String ", "), loc), e'), loc)), loc))
431 e1 es
432 end
433
434 fun strcatR loc e xs = strcatComma loc (map (fn (x, _) => (L'.EField (e, x), loc)) xs)
435
350 fun monoExp (env, st, fm) (all as (e, loc)) = 436 fun monoExp (env, st, fm) (all as (e, loc)) =
351 let 437 let
352 fun poly () = 438 fun poly () =
353 (E.errorAt loc "Unsupported expression"; 439 (E.errorAt loc "Unsupported expression";
354 Print.eprefaces' [("Expression", CorePrint.p_exp env all)]; 440 Print.eprefaces' [("Expression", CorePrint.p_exp env all)];
371 end 457 end
372 in 458 in
373 ((L'.ECon (dk, monoPatCon env pc, eo), loc), fm) 459 ((L'.ECon (dk, monoPatCon env pc, eo), loc), fm)
374 end 460 end
375 | L.ECon _ => poly () 461 | L.ECon _ => poly ()
376 | L.EFfi mx => ((L'.EFfi mx, loc), fm)
377 | L.EFfiApp (m, x, es) =>
378 let
379 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
380 in
381 ((L'.EFfiApp (m, x, es), loc), fm)
382 end
383 462
384 | L.ECApp ((L.EFfi ("Basis", "return"), _), t) => 463 | L.ECApp ((L.EFfi ("Basis", "return"), _), t) =>
385 ((L'.EAbs ("x", monoType env t, (L'.TRecord [], loc), (L'.ERel 0, loc)), loc), fm) 464 let
465 val t = monoType env t
466 in
467 ((L'.EAbs ("x", t,
468 (L'.TFun ((L'.TRecord [], loc), t), loc),
469 (L'.EAbs ("_", (L'.TRecord [], loc), t,
470 (L'.ERel 1, loc)), loc)), loc), fm)
471 end
386 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), t1), _), t2) => 472 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), t1), _), t2) =>
387 let 473 let
388 val t1 = monoType env t1 474 val t1 = monoType env t1
389 val t2 = monoType env t2 475 val t2 = monoType env t2
390 val un = (L'.TRecord [], loc) 476 val un = (L'.TRecord [], loc)
391 val mt1 = (L'.TFun (t1, un), loc) 477 val mt1 = (L'.TFun (un, t1), loc)
392 val mt2 = (L'.TFun (t2, un), loc) 478 val mt2 = (L'.TFun (un, t2), loc)
393 in 479 in
394 ((L'.EAbs ("m1", mt1, (L'.TFun (mt1, (L'.TFun (mt2, un), loc)), loc), 480 ((L'.EAbs ("m1", mt1, (L'.TFun (mt1, (L'.TFun (mt2, (L'.TFun (un, un), loc)), loc)), loc),
395 (L'.EAbs ("m2", mt2, un, 481 (L'.EAbs ("m2", mt2, (L'.TFun (un, un), loc),
396 (L'.ELet ("r", t1, (L'.ERel 1, loc), 482 (L'.EAbs ("_", un, un,
397 (L'.EApp ((L'.ERel 1, loc), (L'.ERel 0, loc)), 483 (L'.ELet ("r", t1, (L'.EApp ((L'.ERel 2, loc),
398 loc)), loc)), loc)), loc), 484 (L'.ERecord [], loc)), loc),
485 (L'.EApp (
486 (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc),
487 (L'.ERecord [], loc)),
488 loc)), loc)), loc)), loc)), loc),
399 fm) 489 fm)
400 end 490 end
401 491
492 | L.ECApp (
493 (L.ECApp (
494 (L.ECApp ((L.EFfi ("Basis", "query"), _), (L.CRecord (_, tables), _)), _),
495 exps), _),
496 state) =>
497 (case monoType env (L.TRecord exps, loc) of
498 (L'.TRecord exps, _) =>
499 let
500 val tables = map (fn ((L.CName x, _), xts) =>
501 (case monoType env (L.TRecord xts, loc) of
502 (L'.TRecord xts, _) => SOME (x, xts)
503 | _ => NONE)
504 | _ => NONE) tables
505 in
506 if List.exists (fn x => x = NONE) tables then
507 poly ()
508 else
509 let
510 val tables = List.mapPartial (fn x => x) tables
511 val state = monoType env state
512 val s = (L'.TFfi ("Basis", "string"), loc)
513 val un = (L'.TRecord [], loc)
514
515 val rt = exps @ map (fn (x, xts) => (x, (L'.TRecord xts, loc))) tables
516 val ft = (L'.TFun ((L'.TRecord rt, loc),
517 (L'.TFun (state,
518 (L'.TFun (un, state), loc)),
519 loc)), loc)
520
521 val body' = (L'.EAbs ("r", (L'.TRecord rt, loc),
522 (L'.TFun (state, state), loc),
523 (L'.EAbs ("acc", state, state,
524 (L'.EApp (
525 (L'.EApp (
526 (L'.EApp ((L'.ERel 4, loc),
527 (L'.ERel 1, loc)), loc),
528 (L'.ERel 0, loc)), loc),
529 (L'.ERecord [], loc)), loc)), loc)), loc)
530
531 val body = (L'.EQuery {exps = exps,
532 tables = tables,
533 state = state,
534 query = (L'.ERel 3, loc),
535 body = body',
536 initial = (L'.ERel 1, loc)},
537 loc)
538 in
539 ((L'.EAbs ("q", s, (L'.TFun (ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc)), loc),
540 (L'.EAbs ("f", ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc),
541 (L'.EAbs ("i", state, (L'.TFun (un, state), loc),
542 (L'.EAbs ("_", un, state,
543 body), loc)), loc)), loc)), loc), fm)
544 end
545 end
546 | _ => poly ())
547
548 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_query"), _), _), _), _), _), _) =>
549 let
550 fun sc s = (L'.EPrim (Prim.String s), loc)
551 val s = (L'.TFfi ("Basis", "string"), loc)
552 fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
553 in
554 ((L'.EAbs ("r",
555 (L'.TRecord [("Rows", s), ("OrderBy", s), ("Limit", s), ("Offset", s)], loc),
556 s,
557 strcat loc [gf "Rows",
558 gf "OrderBy",
559 gf "Limit",
560 gf "Offset"]), loc), fm)
561 end
562
563 | L.ECApp (
564 (L.ECApp (
565 (L.ECApp (
566 (L.ECApp (
567 (L.EFfi ("Basis", "sql_query1"), _),
568 (L.CRecord (_, tables), _)), _),
569 (L.CRecord (_, grouped), _)), _),
570 (L.CRecord (_, stables), _)), _),
571 sexps) =>
572 let
573 fun sc s = (L'.EPrim (Prim.String s), loc)
574 val s = (L'.TFfi ("Basis", "string"), loc)
575 val un = (L'.TRecord [], loc)
576 fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
577
578 fun doTables tables =
579 let
580 val tables = map (fn ((L.CName x, _), xts) =>
581 (case monoType env (L.TRecord xts, loc) of
582 (L'.TRecord xts, _) => SOME (x, xts)
583 | _ => NONE)
584 | _ => NONE) tables
585 in
586 if List.exists (fn x => x = NONE) tables then
587 NONE
588 else
589 SOME (List.mapPartial (fn x => x) tables)
590 end
591 in
592 case (doTables tables, doTables grouped, doTables stables, monoType env (L.TRecord sexps, loc)) of
593 (SOME tables, SOME grouped, SOME stables, (L'.TRecord sexps, _)) =>
594 ((L'.EAbs ("r",
595 (L'.TRecord [("From", (L'.TRecord (map (fn (x, _) => (x, s)) tables), loc)),
596 ("Where", s),
597 ("GroupBy", un),
598 ("Having", s),
599 ("SelectFields", un),
600 ("SelectExps", (L'.TRecord (map (fn (x, _) => (x, s)) sexps), loc))],
601 loc),
602 s,
603 strcat loc [sc "SELECT ",
604 strcatR loc (gf "SelectExps") sexps,
605 case sexps of
606 [] => sc ""
607 | _ => sc ", ",
608 strcatComma loc (map (fn (x, xts) =>
609 strcatComma loc
610 (map (fn (x', _) =>
611 sc (x ^ "." ^ x'))
612 xts)) stables),
613 sc " FROM ",
614 strcatComma loc (map (fn (x, _) => strcat loc [(L'.EField (gf "From", x), loc),
615 sc (" AS " ^ x)]) tables)
616 ]), loc),
617 fm)
618 | _ => poly ()
619 end
620
621 | L.ECApp (
622 (L.ECApp (
623 (L.ECApp (
624 (L.ECApp (
625 (L.EFfi ("Basis", "sql_inject"), _),
626 _), _),
627 _), _),
628 _), _),
629 t) =>
630 let
631 val t = monoType env t
632 val s = (L'.TFfi ("Basis", "string"), loc)
633 in
634 ((L'.EAbs ("f", (L'.TFun (t, s), loc), (L'.TFun (t, s), loc),
635 (L'.ERel 0, loc)), loc), fm)
636 end
637
638 | L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) =>
639 ((L'.ERecord [], loc), fm)
640 | L.ECApp ((L.EFfi ("Basis", "sql_subset_all"), _), _) =>
641 ((L'.ERecord [], loc), fm)
642
643 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) =>
644 ((L'.EPrim (Prim.String ""), loc), fm)
645
646 | L.EFfi ("Basis", "sql_no_limit") =>
647 ((L'.EPrim (Prim.String ""), loc), fm)
648 | L.EFfi ("Basis", "sql_no_offset") =>
649 ((L'.EPrim (Prim.String ""), loc), fm)
650
402 | L.EApp ( 651 | L.EApp (
403 (L.ECApp ( 652 (L.ECApp (
404 (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _), 653 (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
405 _), _), 654 _), _),
406 se) => 655 se) =>
719 ((L'.EAbs (x, monoType env dom, monoType env ran, e), loc), fm) 968 ((L'.EAbs (x, monoType env dom, monoType env ran, e), loc), fm)
720 end 969 end
721 | L.ECApp _ => poly () 970 | L.ECApp _ => poly ()
722 | L.ECAbs _ => poly () 971 | L.ECAbs _ => poly ()
723 972
973 | L.EFfi mx => ((L'.EFfi mx, loc), fm)
974 | L.EFfiApp (m, x, es) =>
975 let
976 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
977 in
978 ((L'.EFfiApp (m, x, es), loc), fm)
979 end
980
724 | L.ERecord xes => 981 | L.ERecord xes =>
725 let 982 let
726 val (xes, fm) = ListUtil.foldlMap 983 val (xes, fm) = ListUtil.foldlMap
727 (fn ((x, e, t), fm) => 984 (fn ((x, e, t), fm) =>
728 let 985 let
760 1017
761 | L.EWrite e => 1018 | L.EWrite e =>
762 let 1019 let
763 val (e, fm) = monoExp (env, st, fm) e 1020 val (e, fm) = monoExp (env, st, fm) e
764 in 1021 in
765 ((L'.EWrite e, loc), fm) 1022 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
1023 (L'.EWrite (liftExpInExp 0 e), loc)), loc), fm)
766 end 1024 end
767 1025
768 | L.EClosure (n, es) => 1026 | L.EClosure (n, es) =>
769 let 1027 let
770 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => 1028 val (es, fm) = ListUtil.foldlMap (fn (e, fm) =>