Mercurial > urweb

comparison src/mono_reduce.sml @ 2084:0d48cfb59b29

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
More aggressive inlining of 'let' with record literals, plus some changes to Monoization of queries, to make inlining more common
author Adam Chlipala <adam@chlipala.net>
date Thu, 04 Dec 2014 02:47:24 -0500
parents 1b76ae703cbb
children 9e9c915f554c
comparison
equal deleted inserted replaced
2083:9f65e2188d3c 2084:0d48cfb59b29
37 structure U = MonoUtil 37 structure U = MonoUtil
38 38
39 structure IM = IntBinaryMap 39 structure IM = IntBinaryMap
40 structure IS = IntBinarySet 40 structure IS = IntBinarySet
41 41
42 structure SS = BinarySetFn(struct
43 type ord_key = string
44 val compare = String.compare
45 end)
42 46
43 fun simpleTypeImpure tsyms = 47 fun simpleTypeImpure tsyms =
44 U.Typ.exists (fn TFun _ => true 48 U.Typ.exists (fn TFun _ => true
45 | TDatatype (n, _) => IS.member (tsyms, n) 49 | TDatatype (n, _) => IS.member (tsyms, n)
46 | _ => false) 50 | _ => false)
590 | (TSignal _, _) => e 594 | (TSignal _, _) => e
591 | _ => 595 | _ =>
592 case e' of 596 case e' of
593 (ECase _, _) => e 597 (ECase _, _) => e
594 | _ => doSub ()) 598 | _ => doSub ())
599
600 fun isRecord () =
601 case #1 e' of
602 ERecord _ => true
603 | _ => false
604
605 fun whichProj i (e : exp) =
606 case #1 e of
607 EPrim _ => SOME SS.empty
608 | ERel i' => if i' = i then NONE else SOME SS.empty
609 | ENamed _ => SOME SS.empty
610 | ECon (_, _, NONE) => SOME SS.empty
611 | ECon (_, _, SOME e') => whichProj i e'
612 | ENone _ => SOME SS.empty
613 | ESome (_, e') => whichProj i e'
614 | EFfi _ => SOME SS.empty
615 | EFfiApp (_, _, es) => whichProjs i (map #1 es)
616 | EApp (e1, e2) => whichProjs i [e1, e2]
617 | EAbs (_, _, _, e) => whichProj (i + 1) e
618 | EUnop (_, e1) => whichProj i e1
619 | EBinop (_, _, e1, e2) => whichProjs i [e1, e2]
620 | ERecord xets => whichProjs i (map #2 xets)
621 | EField ((ERel i', _), s) =>
622 if i' = i then
623 SOME (SS.singleton s)
624 else
625 SOME SS.empty
626 | EField (e1, _) => whichProj i e1
627 | ECase (e1, pes, _) =>
628 whichProjs' i ((0, e1)
629 :: map (fn (p, e) => (patBinds p, e)) pes)
630 | EStrcat (e1, e2) => whichProjs i [e1, e2]
631 | EError (e1, _) => whichProj i e1
632 | EReturnBlob {blob = NONE, mimeType = e2, ...} => whichProj i e2
633 | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => whichProjs i [e1, e2]
634 | ERedirect (e1, _) => whichProj i e1
635 | EWrite e1 => whichProj i e1
636 | ESeq (e1, e2) => whichProjs i [e1, e2]
637 | ELet (_, _, e1, e2) => whichProjs' i [(0, e1), (1, e2)]
638 | EClosure (_, es) => whichProjs i es
639 | EQuery {query = e1, body = e2, initial = e3, ...} =>
640 whichProjs' i [(0, e1), (2, e2), (0, e3)]
641 | EDml (e1, _) => whichProj i e1
642 | ENextval e1 => whichProj i e1
643 | ESetval (e1, e2) => whichProjs i [e1, e2]
644 | EUnurlify (e1, _, _) => whichProj i e1
645 | EJavaScript (_, e1) => whichProj i e1
646 | ESignalReturn e1 => whichProj i e1
647 | ESignalBind (e1, e2) => whichProjs i [e1, e2]
648 | ESignalSource e1 => whichProj i e1
649 | EServerCall (e1, _, _, _) => whichProj i e1
650 | ERecv (e1, _) => whichProj i e1
651 | ESleep e1 => whichProj i e1
652 | ESpawn e1 => whichProj i e1
653
654 and whichProjs i es =
655 whichProjs' i (map (fn e => (0, e)) es)
656
657 and whichProjs' i es =
658 case es of
659 [] => SOME SS.empty
660 | (n, e) :: es' =>
661 case (whichProj (i + n) e, whichProjs' i es') of
662 (SOME m1, SOME m2) =>
663 if SS.isEmpty (SS.intersection (m1, m2)) then
664 SOME (SS.union (m1, m2))
665 else
666 NONE
667 | _ => NONE
595 in 668 in
596 if impure env e' then 669 if impure env e' then
597 let 670 let
598 val effs_e' = summarize 0 e' 671 val effs_e' = summarize 0 e'
599 val effs_e' = List.filter (fn x => x <> UseRel) effs_e' 672 val effs_e' = List.filter (fn x => x <> UseRel) effs_e'
648 andalso not (freeInAbs b) then 721 andalso not (freeInAbs b) then
649 trySub () 722 trySub ()
650 else 723 else
651 e 724 e
652 end 725 end
653 else if countFree 0 0 b > 1 andalso not (!fullMode) andalso not (passive e') then 726 else if countFree 0 0 b > 1
727 andalso not (!fullMode)
728 andalso not (passive e')
729 andalso not (isRecord () andalso Option.isSome (whichProj 0 b)) then
654 e 730 e
655 else 731 else
656 trySub () 732 trySub ()
657 end 733 end
658 734