diff options
| author |  Adam Chlipala <adam@chlipala.net> | 2012-08-05 14:55:28 -0400 |
|---|---|---|
| committer | Adam Chlipala <adam@chlipala.net> | 2012-08-05 14:55:28 -0400 |
| commit | d914989e7ecf17997a2e57d6490b18f6c2b52e5e (patch) | |
| tree | a797edbd3dbd862395a15d69852f3d5e7b846b14 /src/mono_reduce.sml | |
| parent | afdf9924539e1df0a515bb5760fa76ca014395ff (diff) | |
Tweaking treatment of function application: substitute or introduce a 'let'?
Diffstat (limited to 'src/mono_reduce.sml')
| -rw-r--r-- | src/mono_reduce.sml | 24 |
1 files changed, 20 insertions, 4 deletions
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 88628ac2..af61489c 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -179,12 +179,12 @@ val swapExpVarsPat = bind = fn ((lower, len), U.Exp.RelE _) => (lower+1, len) | (st, _) => st} -datatype result = Yes of exp list | No | Maybe +datatype result = Yes of (string * typ * exp) list | No | Maybe fun match (env, p : pat, e : exp) = case (#1 p, #1 e) of (PWild, _) => Yes env - | (PVar (x, t), _) => Yes (e :: env) + | (PVar (x, t), _) => Yes ((x, t, e) :: env) | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) => if String.isPrefix s' s then @@ -519,6 +519,17 @@ fun reduce file = fun doLet (x, t, e', b) = let + val notValue = U.Exp.exists {typ = fn _ => false, + exp = fn e => + case e of + EPrim _ => false + | ECon _ => false + | ENone _ => false + | ESome _ => false + | ERecord _ => false + | _ => true} + + fun doSub () = let val r = subExpInExp (0, e') b @@ -597,6 +608,8 @@ fun reduce file = else e end + else if countFree 0 0 b > 1 andalso notValue e' then + e else trySub () end @@ -659,8 +672,11 @@ fun reduce file = | Yes subs => let val (body, remaining) = - foldl (fn (e, (body, remaining)) => - (subExpInExp (0, multiLift remaining e) body, remaining - 1)) + foldl (fn ((x, t, e), (body, remaining)) => + (if countFree 0 0 body > 1 then + (ELet (x, t, multiLift remaining e, body), #2 e') + else + subExpInExp (0, multiLift remaining e) body, remaining - 1)) (body, length subs - 1) subs val r = reduceExp (E.patBinds env p) body in |