Mercurial > urweb

comparison src/mono_reduce.sml @ 2224:5709482a2afd

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge.
author Ziv Scully <ziv@mit.edu>
date Thu, 11 Dec 2014 02:05:41 -0500
parents 0d48cfb59b29
children 9e9c915f554c
comparison
equal deleted inserted replaced
2223:9410959d296f 2224:5709482a2afd
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)
205 | (PPrim p, EPrim p') => 209 | (PPrim p, EPrim p') =>
206 if Prim.equal (p, p') then 210 if Prim.equal (p, p') then
207 Yes env 211 Yes env
208 else 212 else
209 No 213 No
214
215 | (PPrim (Prim.String (_, s)), _) =>
216 let
217 fun lengthLb (e : exp) =
218 case #1 e of
219 EStrcat (e1, e2) => lengthLb e1 + lengthLb e2
220 | EPrim (Prim.String (_, s)) => size s
221 | _ => 0
222 in
223 if lengthLb e > size s then
224 No
225 else
226 Maybe
227 end
210 228
211 | (PCon (_, PConVar n1, po), ECon (_, PConVar n2, eo)) => 229 | (PCon (_, PConVar n1, po), ECon (_, PConVar n2, eo)) =>
212 if n1 = n2 then 230 if n1 = n2 then
213 case (po, eo) of 231 case (po, eo) of
214 (NONE, NONE) => Yes env 232 (NONE, NONE) => Yes env
576 | (TSignal _, _) => e 594 | (TSignal _, _) => e
577 | _ => 595 | _ =>
578 case e' of 596 case e' of
579 (ECase _, _) => e 597 (ECase _, _) => e
580 | _ => 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
581 in 668 in
582 if impure env e' then 669 if impure env e' then
583 let 670 let
584 val effs_e' = summarize 0 e' 671 val effs_e' = summarize 0 e'
585 val effs_e' = List.filter (fn x => x <> UseRel) effs_e' 672 val effs_e' = List.filter (fn x => x <> UseRel) effs_e'
634 andalso not (freeInAbs b) then 721 andalso not (freeInAbs b) then
635 trySub () 722 trySub ()
636 else 723 else
637 e 724 e
638 end 725 end
639 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
640 e 730 e
641 else 731 else
642 trySub () 732 trySub ()
643 end 733 end
644 734