Mercurial > urweb

comparison src/mono_reduce.sml @ 1855:0480b8f29a47

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Undo 'let' inlining tweak; improve optimization of 'case' of type 'transaction'
author Adam Chlipala <adam@chlipala.net>
date Fri, 07 Jun 2013 16:11:52 -0400
parents bddd0ec5d3da
children 98895243b5b6
comparison
equal deleted inserted replaced
1854:bddd0ec5d3da 1855:0480b8f29a47
562 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), 562 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
563 ("r", MonoPrint.p_exp env r)];*) 563 ("r", MonoPrint.p_exp env r)];*)
564 #1 (reduceExp env r) 564 #1 (reduceExp env r)
565 end 565 end
566 566
567 fun trySub pure = 567 fun trySub () =
568 ((*Print.prefaces "trySub" 568 ((*Print.prefaces "trySub"
569 [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))];*) 569 [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))];*)
570 case t of 570 case t of
571 (TFfi ("Basis", "string"), _) => doSub () 571 (TFfi ("Basis", "string"), _) => doSub ()
572 | (TSignal _, _) => e 572 | (TSignal _, _) => e
573 | _ => 573 | _ =>
574 if pure then 574 case e' of
575 doSub () 575 (ECase _, _) => e
576 else 576 | _ => doSub ())
577 case e' of
578 (ECase _, _) => e
579 | _ => doSub ())
580 in 577 in
581 if impure env e' then 578 if impure env e' then
582 let 579 let
583 val effs_e' = summarize 0 e' 580 val effs_e' = summarize 0 e'
584 val effs_e' = List.filter (fn x => x <> UseRel) effs_e' 581 val effs_e' = List.filter (fn x => x <> UseRel) effs_e'
629 orelse (case effs_b of 626 orelse (case effs_b of
630 UseRel :: effs => List.all verifyUnused effs 627 UseRel :: effs => List.all verifyUnused effs
631 | _ => false)) 628 | _ => false))
632 andalso countFree 0 0 b = 1 629 andalso countFree 0 0 b = 1
633 andalso not (freeInAbs b) then 630 andalso not (freeInAbs b) then
634 trySub (List.null effs_e') 631 trySub ()
635 else 632 else
636 e 633 e
637 end 634 end
638 else if countFree 0 0 b > 1 andalso not (!fullMode) andalso not (passive e') then 635 else if countFree 0 0 b > 1 andalso not (!fullMode) andalso not (passive e') then
639 e 636 e
640 else 637 else
641 trySub true 638 trySub ()
642 end 639 end
643 640
644 val r = 641 val r =
645 case e of 642 case e of
646 ERel n => 643 ERel n =>
667 let 664 let
668 fun push () = 665 fun push () =
669 case result of 666 case result of
670 (TFun (dom, result), loc) => 667 (TFun (dom, result), loc) =>
671 let 668 let
672 fun safe (e, _) = 669 fun safe e =
673 case e of 670 List.all (fn UseRel => true
674 EAbs _ => true 671 | Abort => true
675 | EError _ => true 672 | _ => false) (summarize 0 e)
676 | _ => false 673
674 fun p_events' es = Print.box [Print.PD.string "{",
675 p_events es,
676 Print.PD.string "}"]
677 in 677 in
678 if List.all (safe o #2) pes then 678 if List.all (safe o #2) pes then
679 EAbs ("y", dom, result, 679 EAbs ("y", dom, result,
680 (ECase (liftExpInExp 0 e', 680 (ECase (liftExpInExp 0 e',
681 map (fn (p, (EAbs (_, _, _, e), _)) => 681 map (fn (p, (EAbs (_, _, _, e), _)) =>
682 (p, swapExpVarsPat (0, patBinds p) e) 682 (p, swapExpVarsPat (0, patBinds p) e)
683 | (p, (EError (e, (TFun (_, t), _)), loc)) => 683 | (p, (EError (e, (TFun (_, t), _)), loc)) =>
684 (p, (EError (e, t), loc)) 684 (p, (EError (e, t), loc))
685 | _ => raise Fail "MonoReduce ECase") pes, 685 | (p, e) =>
686 (p, (EApp (liftExpInExp (patBinds p) e,
687 (ERel (patBinds p), loc)), loc)))
688 pes,
686 {disc = disc, result = result}), loc)) 689 {disc = disc, result = result}), loc))
687 else 690 else
688 e 691 e
689 end 692 end
690 | _ => e 693 | _ => e