Mercurial > urweb

comparison src/mono_reduce.sml @ 1852:3c93e91e97da

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Get Iflow working again
author Adam Chlipala <adam@chlipala.net>
date Sun, 21 Apr 2013 13:03:20 -0400
parents e15234fbb163
children bddd0ec5d3da
comparison
equal deleted inserted replaced
1851:1239ba1a1671 1852:3c93e91e97da
28 (* Simplify a Mono program algebraically *) 28 (* Simplify a Mono program algebraically *)
29 29
30 structure MonoReduce :> MONO_REDUCE = struct 30 structure MonoReduce :> MONO_REDUCE = struct
31 31
32 open Mono 32 open Mono
33
34 val fullMode = ref false
33 35
34 structure E = MonoEnv 36 structure E = MonoEnv
35 structure U = MonoUtil 37 structure U = MonoUtil
36 38
37 structure IM = IntBinaryMap 39 structure IM = IntBinaryMap
529 531
530 val impure = fn env => fn e => 532 val impure = fn env => fn e =>
531 simpleImpure (timpures, impures) env e andalso impure e 533 simpleImpure (timpures, impures) env e andalso impure e
532 andalso not (List.null (summarize ~1 e)) 534 andalso not (List.null (summarize ~1 e))
533 535
536 fun passive (e : exp) =
537 case #1 e of
538 EPrim _ => true
539 | ERel _ => true
540 | ENamed _ => true
541 | ECon (_, _, NONE) => true
542 | ECon (_, _, SOME e) => passive e
543 | ENone _ => true
544 | ESome (_, e) => passive e
545 | EFfi _ => true
546 | EAbs _ => true
547 | ERecord xets => List.all (passive o #2) xets
548 | EField (e, _) => passive e
549 | _ => false
550
534 fun exp env e = 551 fun exp env e =
535 let 552 let
536 (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*) 553 (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*)
537 554
538 fun doLet (x, t, e', b) = 555 fun doLet (x, t, e', b) =
539 let 556 let
540 fun passive (e : exp) =
541 case #1 e of
542 EPrim _ => true
543 | ERel _ => true
544 | ENamed _ => true
545 | ECon (_, _, NONE) => true
546 | ECon (_, _, SOME e) => passive e
547 | ENone _ => true
548 | ESome (_, e) => passive e
549 | EFfi _ => true
550 | EAbs _ => true
551 | ERecord xets => List.all (passive o #2) xets
552 | EField (e, _) => passive e
553 | _ => false
554
555 fun doSub () = 557 fun doSub () =
556 let 558 let
557 val r = subExpInExp (0, e') b 559 val r = subExpInExp (0, e') b
558 in 560 in
559 (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'), 561 (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'),
628 andalso not (freeInAbs b) then 630 andalso not (freeInAbs b) then
629 trySub () 631 trySub ()
630 else 632 else
631 e 633 e
632 end 634 end
633 else if countFree 0 0 b > 1 andalso not (passive e') then 635 else if countFree 0 0 b > 1 andalso not (!fullMode) andalso not (passive e') then
634 e 636 e
635 else 637 else
636 trySub () 638 trySub ()
637 end 639 end
638 640
651 653
652 | EApp ((EAbs (x, t, _, e1), loc), e2) => 654 | EApp ((EAbs (x, t, _, e1), loc), e2) =>
653 ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1), 655 ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1),
654 ("e2", MonoPrint.p_exp env e2), 656 ("e2", MonoPrint.p_exp env e2),
655 ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*) 657 ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*)
656 if impure env e2 orelse countFree 0 0 e1 > 1 then 658 if impure env e2 orelse (not (!fullMode) andalso countFree 0 0 e1 > 1) then
657 #1 (reduceExp env (ELet (x, t, e2, e1), loc)) 659 #1 (reduceExp env (ELet (x, t, e2, e1), loc))
658 else 660 else
659 #1 (reduceExp env (subExpInExp (0, e2) e1))) 661 #1 (reduceExp env (subExpInExp (0, e2) e1)))
660 662
661 | ECase (e', pes, {disc, result}) => 663 | ECase (e', pes, {disc, result}) =>