Mercurial > urweb
changeset 800:e92cfac1608f
Proper lifting of MonoEnv stored expressions; avoidance of onchange clobbering
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 14 May 2009 13:18:31 -0400 |
| parents | 9330ba3a2799 |
| children | 5f49a6b759cb |
| files | lib/js/urweb.js lib/ur/list.ur lib/ur/list.urs src/especialize.sml src/jscomp.sml src/mono_env.sml src/mono_reduce.sml src/monoize.sml |
| diffstat | 8 files changed, 154 insertions(+), 18 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/js/urweb.js Thu May 14 11:04:56 2009 -0400 +++ b/lib/js/urweb.js Thu May 14 13:18:31 2009 -0400 @@ -301,11 +301,19 @@ return x; } +function addOnChange(x, f) { + var old = x.onchange; + x.onchange = function() { old(); f (); }; +} + // Basic string operations function eh(x) { - return x.split("&").join("&").split("<").join("<").split(">").join(">"); + if (x == null) + return "NULL"; + else + return x.split("&").join("&").split("<").join("<").split(">").join(">"); } function ts(x) { return x.toString() }
--- a/lib/ur/list.ur Thu May 14 11:04:56 2009 -0400 +++ b/lib/ur/list.ur Thu May 14 13:18:31 2009 -0400 @@ -39,3 +39,13 @@ in mapX' end + +fun mapM (m ::: (Type -> Type)) (_ : monad m) (a ::: Type) (b ::: Type) f = + let + fun mapM' acc ls = + case ls of + [] => acc + | x :: ls => mapM' (x' <- f x; ls' <- acc; return (x' :: ls')) ls + in + mapM' (return []) + end
--- a/lib/ur/list.urs Thu May 14 11:04:56 2009 -0400 +++ b/lib/ur/list.urs Thu May 14 13:18:31 2009 -0400 @@ -7,3 +7,6 @@ val mp : a ::: Type -> b ::: Type -> (a -> b) -> t a -> t b val mapX : a ::: Type -> ctx ::: {Unit} -> (a -> xml ctx [] []) -> t a -> xml ctx [] [] + +val mapM : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type + -> (a -> m b) -> list a -> m (list b)
--- a/src/especialize.sml Thu May 14 11:04:56 2009 -0400 +++ b/src/especialize.sml Thu May 14 13:18:31 2009 -0400 @@ -112,6 +112,13 @@ fun default (_, x, st) = (x, st) +structure SS = BinarySetFn(struct + type ord_key = string + val compare = String.compare + end) + +val mayNotSpec = ref SS.empty + fun specialize' file = let fun bind (env, b) = @@ -179,13 +186,14 @@ (ERel _, _) :: _ => true | _ => false in + (*Print.preface ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs');*) if firstRel () orelse List.all (fn (ERel _, _) => true | _ => false) fxs' then (e, st) else - case KM.find (args, fxs') of - SOME f' => + case (KM.find (args, fxs'), SS.member (!mayNotSpec, name)) of + (SOME f', _) => let val e = (ENamed f', loc) val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc)) @@ -197,8 +205,14 @@ [("e'", CorePrint.p_exp CoreEnv.empty e)];*) (#1 e, st) end - | NONE => + | (_, true) => (e, st) + | (NONE, false) => let + (*val () = Print.prefaces "New one" + [("f", Print.PD.string (Int.toString f)), + ("mns", Print.p_list Print.PD.string + (SS.listItems (!mayNotSpec)))]*) + fun subBody (body, typ, fxs') = case (#1 body, #1 typ, fxs') of (_, _, []) => SOME (body, typ) @@ -245,7 +259,11 @@ (TFun (xt, typ'), loc)) end) (body', typ') fvs + val mns = !mayNotSpec + val () = mayNotSpec := SS.add (mns, name) + (*val () = Print.preface ("body'", CorePrint.p_exp CoreEnv.empty body')*) val (body', st) = specExp env st body' + val () = mayNotSpec := mns val e' = (ENamed f', loc) val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc)) @@ -297,7 +315,13 @@ if isPoly d then (d, st) else - specDecl [] st d + (mayNotSpec := (case #1 d of + DValRec vis => foldl (fn ((x, _, _, _, _), mns) => + SS.add (mns, x)) SS.empty vis + | DVal (x, _, _, _, _) => SS.singleton x + | _ => SS.empty); + specDecl [] st d + before mayNotSpec := SS.empty) (*val () = print "/decl\n"*) @@ -324,9 +348,7 @@ (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)] | _ => [(DValRec vis, ErrorMsg.dummySpan), d']) in - (*Print.prefaces "doDecl" [("d", CorePrint.p_decl E.empty d), - ("t", Print.PD.string (Real.toString (Time.toReal - (Time.- (Time.now (), befor)))))];*) + (*Print.prefaces "doDecl" [("d", CorePrint.p_decl E.empty d)];*) (ds, ({maxName = #maxName st, funcs = funcs, decls = []}, changed))
--- a/src/jscomp.sml Thu May 14 11:04:56 2009 -0400 +++ b/src/jscomp.sml Thu May 14 13:18:31 2009 -0400 @@ -36,11 +36,17 @@ structure IS = IntBinarySet structure IM = IntBinaryMap +structure TM = BinaryMapFn(struct + type ord_key = typ + val compare = U.Typ.compare + end) + type state = { decls : decl list, script : string list, included : IS.set, injectors : int IM.map, + listInjectors : int TM.map, decoders : int IM.map, maxName : int } @@ -231,6 +237,52 @@ st) end + | TList t' => + (case TM.find (#listInjectors st, t') of + SOME n' => ((EApp ((ENamed n', loc), e), loc), st) + | NONE => + let + val rt = (TRecord [("1", t'), ("2", t)], loc) + + val n' = #maxName st + val st = {decls = #decls st, + script = #script st, + included = #included st, + injectors = #injectors st, + listInjectors = TM.insert (#listInjectors st, t', n'), + decoders = #decoders st, + maxName = n' + 1} + + val s = (TFfi ("Basis", "string"), loc) + val (e', st) = quoteExp loc t ((EField ((ERel 0, loc), "1"), loc), st) + + val body = (ECase ((ERel 0, loc), + [((PNone rt, loc), + str loc "null"), + ((PSome (rt, (PVar ("x", rt), loc)), loc), + strcat loc [str loc "{v:{_1:", + e', + str loc ",_2:", + (EApp ((ENamed n', loc), + (EField ((ERel 0, loc), "2"), loc)), loc), + str loc "}}"])], + {disc = t, result = s}), loc) + val body = (EAbs ("x", t, s, body), loc) + + val st = {decls = (DValRec [("jsify", n', (TFun (t, s), loc), + body, "jsify")], loc) :: #decls st, + script = #script st, + included = #included st, + injectors = #injectors st, + listInjectors = #listInjectors st, + decoders= #decoders st, + maxName = #maxName st} + + + in + ((EApp ((ENamed n', loc), e), loc), st) + end) + | TDatatype (n, ref (dk, cs)) => (case IM.find (#injectors st, n) of SOME n' => ((EApp ((ENamed n', loc), e), loc), st) @@ -241,6 +293,7 @@ script = #script st, included = #included st, injectors = IM.insert (#injectors st, n, n'), + listInjectors = #listInjectors st, decoders = #decoders st, maxName = n' + 1} @@ -282,6 +335,7 @@ script = #script st, included = #included st, injectors = #injectors st, + listInjectors = #listInjectors st, decoders= #decoders st, maxName = #maxName st} in @@ -350,6 +404,7 @@ script = #script st, included = #included st, injectors = #injectors st, + listInjectors = #listInjectors st, decoders = IM.insert (#decoders st, n, n'), maxName = n' + 1} @@ -384,6 +439,7 @@ script = body :: #script st, included = #included st, injectors = #injectors st, + listInjectors = #listInjectors st, decoders = #decoders st, maxName = #maxName st} in @@ -402,7 +458,7 @@ val foundJavaScript = ref false - fun jsExp mode skip outer = + fun jsExp mode outer = let val len = length outer @@ -575,7 +631,7 @@ let val n = n - inner in - quoteExp (List.nth (outer, n)) ((ERel (n - skip), loc), st) + quoteExp (List.nth (outer, n)) ((ERel n, loc), st) end | ENamed n => @@ -592,10 +648,11 @@ script = #script st, included = IS.add (#included st, n), injectors = #injectors st, + listInjectors = #listInjectors st, decoders = #decoders st, maxName = #maxName st} - val (e, st) = jsExp mode skip [] 0 (e, st) + val (e, st) = jsExp mode [] 0 (e, st) val e = deStrcat 0 e val sc = "_n" ^ Int.toString n ^ "=" ^ e ^ ";\n" @@ -604,6 +661,7 @@ script = sc :: #script st, included = #included st, injectors = #injectors st, + listInjectors = #listInjectors st, decoders= #decoders st, maxName = #maxName st} end @@ -988,7 +1046,7 @@ U.Decl.foldMapB {typ = fn x => x, exp = fn (env, e, st) => let - fun doCode m skip env orig e = + fun doCode m env orig e = let val len = length env fun str s = (EPrim (Prim.String s), #2 e) @@ -996,7 +1054,7 @@ val locals = List.tabulate (varDepth e, fn i => str ("var _" ^ Int.toString (len + i) ^ ";")) - val (e, st) = jsExp m skip env 0 (e, st) + val (e, st) = jsExp m env 0 (e, st) in (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st) end @@ -1004,7 +1062,7 @@ case e of EJavaScript (m, orig, NONE) => (foundJavaScript := true; - doCode m 0 env orig orig) + doCode m env orig orig) | _ => (e, st) end, decl = fn (_, e, st) => (e, st), @@ -1021,6 +1079,7 @@ script = #script st, included = #included st, injectors = #injectors st, + listInjectors = #listInjectors st, decoders = #decoders st, maxName = #maxName st}) end @@ -1030,6 +1089,7 @@ script = [], included = IS.empty, injectors = IM.empty, + listInjectors = TM.empty, decoders = IM.empty, maxName = U.File.maxName file + 1} file
--- a/src/mono_env.sml Thu May 14 11:04:56 2009 -0400 +++ b/src/mono_env.sml Thu May 14 13:18:31 2009 -0400 @@ -70,11 +70,25 @@ NONE => raise UnboundNamed n | SOME x => x +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} + fun pushERel (env : env) x t eo = {datatypes = #datatypes env, constructors = #constructors env, - - relE = (x, t, eo) :: #relE env, + relE = (x, t, eo) :: map (fn (x, t, eo) => (x, t, Option.map (liftExpInExp 0) eo)) (#relE env), namedE = #namedE env} fun lookupERel (env : env) n =
--- a/src/mono_reduce.sml Thu May 14 11:04:56 2009 -0400 +++ b/src/mono_reduce.sml Thu May 14 13:18:31 2009 -0400 @@ -409,7 +409,15 @@ case match (env, p, e') of No => search pes | Maybe => push () - | Yes env => #1 (reduceExp env body) + | Yes env' => + let + val r = reduceExp env' body + in + (*Print.prefaces "ECase" + [("body", MonoPrint.p_exp env' body), + ("r", MonoPrint.p_exp env r)];*) + #1 r + end in search pes end @@ -443,7 +451,14 @@ | ELet (x, t, e', b) => let fun doSub () = - #1 (reduceExp env (subExpInExp (0, e') b)) + let + val r = subExpInExp (0, e') b + in + (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'), + ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), + ("r", MonoPrint.p_exp env r)];*) + #1 (reduceExp env r) + end fun trySub () = case t of
--- a/src/monoize.sml Thu May 14 11:04:56 2009 -0400 +++ b/src/monoize.sml Thu May 14 13:18:31 2009 -0400 @@ -2498,6 +2498,10 @@ val assgns = List.mapPartial (fn ("Source", _, _) => NONE + | ("Onchange", e, _) => + SOME (strcat [str "addOnChange(d,", + (L'.EJavaScript (L'.Script, e, NONE), loc), + str ")"]) | (x, e, _) => SOME (strcat [str ("d." ^ lowercaseFirst x ^ "="), (L'.EJavaScript (L'.Script, e, NONE), loc),