diff options
Diffstat (limited to 'src/mono_reduce.sml')
| -rw-r--r-- | src/mono_reduce.sml | 99 |
1 files changed, 78 insertions, 21 deletions
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 31757daa..1941f0cc 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -34,20 +34,38 @@ open Mono structure E = MonoEnv structure U = MonoUtil -val liftExpInExp = - U.Exp.mapB {typ = fn t => t, - exp = fn bound => fn e => - case e of - ERel xn => - if xn < bound then - e - else - ERel (xn + 1) - | _ => e, - bind = fn (bound, U.Exp.RelE _) => bound + 1 - | (bound, _) => bound} - -val subExpInExp = + +fun impure (e, _) = + case e of + EWrite _ => true + | EQuery _ => true + | EAbs _ => false + + | EPrim _ => false + | ERel _ => false + | ENamed _ => false + | ECon (_, _, eo) => (case eo of NONE => false | SOME e => impure e) + | EFfi _ => false + | EFfiApp _ => false + | EApp ((EFfi _, _), _) => false + | EApp _ => true + + | ERecord xes => List.exists (fn (_, e, _) => impure e) xes + | EField (e, _) => impure e + + | ECase (e, pes, _) => impure e orelse List.exists (fn (_, e) => impure e) pes + + | EStrcat (e1, e2) => impure e1 orelse impure e2 + + | ESeq (e1, e2) => impure e1 orelse impure e2 + | ELet (_, _, e1, e2) => impure e1 orelse impure e2 + + | EClosure (_, es) => List.exists impure es + + +val liftExpInExp = Monoize.liftExpInExp + +val subExpInExp' = U.Exp.mapB {typ = fn t => t, exp = fn (xn, rep) => fn e => case e of @@ -60,11 +78,15 @@ val subExpInExp = bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep) | (ctx, _) => ctx} -fun bind (env, b) = - case b of - U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs - | U.Decl.RelE (x, t) => E.pushERel env x t NONE - | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s +fun subExpInExp (n, e1) e2 = + let + val r = subExpInExp' (n, e1) e2 + in + (*Print.prefaces "subExpInExp" [("e1", MonoPrint.p_exp MonoEnv.empty e1), + ("e2", MonoPrint.p_exp MonoEnv.empty e2), + ("r", MonoPrint.p_exp MonoEnv.empty r)];*) + r + end fun typ c = c @@ -132,8 +154,13 @@ fun exp env e = (_, _, SOME e', _) => #1 e' | _ => e) - | EApp ((EAbs (_, _, _, e1), loc), e2) => - #1 (reduceExp env (subExpInExp (0, e2) e1)) + | EApp ((EAbs (x, t, _, e1), loc), e2) => + ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp env e1), + ("e2", MonoPrint.p_exp env e2)];*) + if impure e2 then + #1 (reduceExp env (ELet (x, t, e2, e1), loc)) + else + #1 (reduceExp env (subExpInExp (0, e2) e1))) | ECase (disc, pes, _) => (case ListUtil.search (fn (p, body) => @@ -143,8 +170,38 @@ fun exp env e = NONE => e | SOME e' => e') + | EField ((ERecord xes, _), x) => + (case List.find (fn (x', _, _) => x' = x) xes of + SOME (_, e, _) => #1 e + | NONE => e) + + | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) => + let + val e' = (ELet (x2, t2, e1, + (ELet (x1, t1, b1, + liftExpInExp 1 b2), loc)), loc) + in + Print.prefaces "ELet commute" [("e", MonoPrint.p_exp env (e, loc)), + ("e'", MonoPrint.p_exp env e')]; + #1 (reduceExp env e') + end + | EApp ((ELet (x, t, e, b), loc), e') => + #1 (reduceExp env (ELet (x, t, e, + (EApp (b, liftExpInExp 0 e'), loc)), loc)) + | ELet (x, t, e', b) => + if impure e' then + e + else + #1 (reduceExp env (subExpInExp (0, e') b)) + | _ => e +and bind (env, b) = + case b of + U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs + | U.Decl.RelE (x, t) => E.pushERel env x t NONE + | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t (Option.map (reduceExp env) eo) s + and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env fun decl env d = d |