Mercurial > urweb
diff src/especialize.sml @ 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 | dc3fc3f3b834 |
children | ef6de4075dc1 |
line wrap: on
line diff
--- 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))