Mercurial > urweb
changeset 1805:d12192c7aa3e
Revert last changeset for now; needs more thought
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Sun, 05 Aug 2012 17:11:39 -0400 |
| parents | 62c18ecbfec4 |
| children | 40557fb08e98 |
| files | src/especialize.sml src/mono_reduce.sml src/monoize.sml src/reduce.sml tests/badInline.ur |
| diffstat | 5 files changed, 39 insertions(+), 99 deletions(-) [+] |
line wrap: on
line diff
--- a/src/especialize.sml Sun Aug 05 14:55:28 2012 -0400 +++ b/src/especialize.sml Sun Aug 05 17:11:39 2012 -0400 @@ -124,7 +124,6 @@ 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
--- a/src/mono_reduce.sml Sun Aug 05 14:55:28 2012 -0400 +++ b/src/mono_reduce.sml Sun Aug 05 17:11:39 2012 -0400 @@ -179,12 +179,12 @@ bind = fn ((lower, len), U.Exp.RelE _) => (lower+1, len) | (st, _) => st} -datatype result = Yes of (string * typ * exp) list | No | Maybe +datatype result = Yes of exp list | No | Maybe fun match (env, p : pat, e : exp) = case (#1 p, #1 e) of (PWild, _) => Yes env - | (PVar (x, t), _) => Yes ((x, t, e) :: env) + | (PVar (x, t), _) => Yes (e :: env) | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) => if String.isPrefix s' s then @@ -519,17 +519,6 @@ 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 @@ -608,8 +597,6 @@ else e end - else if countFree 0 0 b > 1 andalso notValue e' then - e else trySub () end @@ -672,11 +659,8 @@ | Yes subs => let val (body, remaining) = - 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)) + foldl (fn (e, (body, remaining)) => + (subExpInExp (0, multiLift remaining e) body, remaining - 1)) (body, length subs - 1) subs val r = reduceExp (E.patBinds env p) body in
--- a/src/monoize.sml Sun Aug 05 14:55:28 2012 -0400 +++ b/src/monoize.sml Sun Aug 05 17:11:39 2012 -0400 @@ -3257,29 +3257,29 @@ val t = (L'.TFfi ("Basis", "string"), loc) val s = (L'.EPrim (Prim.String (String.concat ["<", tag'])), 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 = (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, fm) = foldl (fn (("Action", _, _), acc) => acc | (("Source", _, _), acc) => acc
--- a/src/reduce.sml Sun Aug 05 14:55:28 2012 -0400 +++ b/src/reduce.sml Sun Aug 05 17:11:39 2012 -0400 @@ -232,21 +232,6 @@ ((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)) = @@ -549,30 +534,16 @@ val e2 = exp env e2 in case #1 e1 of - 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 - + 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 | ECase (e, pes, cc as {disc, result = res as (TFun (_, c2), _)}) => let val pes' = map (fn (p, body) => @@ -789,14 +760,12 @@ | ELet (x, t, e1, e2) => let - val e1' = exp env e1 - val t = con env t in - if passive e1' orelse count e2 <= 1 orelse ESpecialize.functionInside t then + if ESpecialize.functionInside t then exp (KnownE e1 :: env) e2 else - (ELet (x, t, e1', exp (UnknownE :: env) e2), loc) + (ELet (x, t, exp env e1, exp (UnknownE :: env) e2), loc) end | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, con env t), loc)
--- a/tests/badInline.ur Sun Aug 05 14:55:28 2012 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,12 +0,0 @@ -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 <xml><body> - <p class={ifClass (n = 0) s1 - (ifClass (n = 1) s2 - (ifClass (n = 2) s3 - null))}>Hi</p> -</body></xml>