From eca19ded03603dd3cb51ee403cb41f44f2f05edb Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 5 Aug 2012 14:55:28 -0400 Subject: Tweaking treatment of function application: substitute or introduce a 'let'? --- src/especialize.sml | 1 + src/mono_reduce.sml | 24 +++++++++++++++++++---- src/monoize.sml | 46 ++++++++++++++++++++++---------------------- src/reduce.sml | 55 +++++++++++++++++++++++++++++++++++++++++------------ tests/badInline.ur | 12 ++++++++++++ 5 files changed, 99 insertions(+), 39 deletions(-) create mode 100644 tests/badInline.ur diff --git a/src/especialize.sml b/src/especialize.sml index d6bf7eba..a3d59ef9 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -124,6 +124,7 @@ fun default (_, x, st) = (x, st) val functionInside = U.Con.exists {kind = fn _ => false, con = fn TFun _ => true + | TCFun _ => true | CFfi ("Basis", "transaction") => true | CFfi ("Basis", "eq") => true | CFfi ("Basis", "num") => true 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 diff --git a/src/monoize.sml b/src/monoize.sml index 1b9c97ed..edc13c3f 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3257,29 +3257,29 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val t = (L'.TFfi ("Basis", "string"), loc) val s = (L'.EPrim (Prim.String (String.concat ["<", tag'])), loc) - val s = (L'.ECase (class, - [((L'.PPrim (Prim.String ""), loc), - s), - ((L'.PVar ("x", t), loc), - (L'.EStrcat (s, - (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc), - (L'.EStrcat ((L'.ERel 0, loc), - (L'.EPrim (Prim.String "\""), loc)), - loc)), loc)), loc))], - {disc = t, - result = t}), loc) - - val s = (L'.ECase (style, - [((L'.PPrim (Prim.String ""), loc), - s), - ((L'.PVar ("x", t), loc), - (L'.EStrcat (s, - (L'.EStrcat ((L'.EPrim (Prim.String " style=\""), loc), - (L'.EStrcat ((L'.ERel 0, loc), - (L'.EPrim (Prim.String "\""), loc)), - loc)), loc)), loc))], - {disc = t, - result = t}), loc) + val s = (L'.EStrcat (s, + (L'.ECase (class, + [((L'.PPrim (Prim.String ""), loc), + (L'.EPrim (Prim.String ""), loc)), + ((L'.PVar ("x", t), loc), + (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc), + (L'.EStrcat ((L'.ERel 0, loc), + (L'.EPrim (Prim.String "\""), loc)), + loc)), loc))], + {disc = t, + result = t}), loc)), loc) + + val s = (L'.EStrcat (s, + (L'.ECase (style, + [((L'.PPrim (Prim.String ""), loc), + (L'.EPrim (Prim.String ""), loc)), + ((L'.PVar ("x", t), loc), + (L'.EStrcat ((L'.EPrim (Prim.String " style=\""), loc), + (L'.EStrcat ((L'.ERel 0, loc), + (L'.EPrim (Prim.String "\""), loc)), + loc)), loc))], + {disc = t, + result = t}), loc)), loc) val (s, fm) = foldl (fn (("Action", _, _), acc) => acc | (("Source", _, _), acc) => acc diff --git a/src/reduce.sml b/src/reduce.sml index 1fbf526d..c5733b97 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -232,6 +232,21 @@ fun monadRecord m loc = ((CName "Bind", loc), bindType m loc)]), loc), loc) +fun passive (e : exp) = + case #1 e of + EPrim _ => true + | ERel _ => true + | ENamed _ => true + | ECon (_, _, _, NONE) => true + | ECon (_, _, _, SOME e) => passive e + | EFfi _ => true + | EAbs _ => true + | ECAbs _ => true + | EKAbs _ => true + | ERecord xes => List.all (passive o #2) xes + | EField (e, _, _) => passive e + | _ => false + fun kindConAndExp (namedC, namedE) = let fun kind env (all as (k, loc)) = @@ -534,16 +549,30 @@ fun kindConAndExp (namedC, namedE) = val e2 = exp env e2 in case #1 e1 of - EAbs (_, _, _, b) => - let - val r = exp (KnownE e2 :: env') b - in - (*Print.prefaces "eapp" [("b", CorePrint.p_exp CoreEnv.empty b), - ("env", Print.PD.string (e2s env')), - ("e2", CorePrint.p_exp CoreEnv.empty e2), - ("r", CorePrint.p_exp CoreEnv.empty r)];*) - r - end + ELet (x, t, e1', e2') => + (ELet (x, t, e1', exp (UnknownE :: env') (EApp (e2', E.liftExpInExp 0 e2), loc)), loc) + + | EAbs (x, dom, _, b) => + if count b <= 1 orelse passive e2 orelse ESpecialize.functionInside dom then + let + val r = exp (KnownE e2 :: env') b + in + (*Print.prefaces "eapp" [("b", CorePrint.p_exp CoreEnv.empty b), + ("env", Print.PD.string (e2s env')), + ("e2", CorePrint.p_exp CoreEnv.empty e2), + ("r", CorePrint.p_exp CoreEnv.empty r)];*) + r + end + else + let + val dom = con env' dom + val r = exp (UnknownE :: env') b + in + (*Print.prefaces "El skippo" [("x", Print.PD.string x), + ("e2", CorePrint.p_exp CoreEnv.empty e2)];*) + (ELet (x, dom, e2, r), loc) + end + | ECase (e, pes, cc as {disc, result = res as (TFun (_, c2), _)}) => let val pes' = map (fn (p, body) => @@ -760,12 +789,14 @@ fun kindConAndExp (namedC, namedE) = | ELet (x, t, e1, e2) => let + val e1' = exp env e1 + val t = con env t in - if ESpecialize.functionInside t then + if passive e1' orelse count e2 <= 1 orelse ESpecialize.functionInside t then exp (KnownE e1 :: env) e2 else - (ELet (x, t, exp env e1, exp (UnknownE :: env) e2), loc) + (ELet (x, t, e1', exp (UnknownE :: env) e2), loc) end | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, con env t), loc) diff --git a/tests/badInline.ur b/tests/badInline.ur new file mode 100644 index 00000000..bfbdba79 --- /dev/null +++ b/tests/badInline.ur @@ -0,0 +1,12 @@ +style s1 +style s2 +style s3 + +fun ifClass r cls c = if r then classes cls c else c + +fun main (n : int) : transaction page = return +

Hi

+ -- cgit v1.2.3