Mercurial > urweb
changeset 1667:833402503855
Tweak Especialize heuristic to prevent non-termination
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Mon, 09 Jan 2012 09:51:39 -0500 |
| parents | df8f18d50746 |
| children | 64c1e65c2365 |
| files | src/especialize.sml |
| diffstat | 1 files changed, 15 insertions(+), 28 deletions(-) [+] |
line wrap: on
line diff
--- a/src/especialize.sml Mon Jan 09 08:38:53 2012 -0500 +++ b/src/especialize.sml Mon Jan 09 09:51:39 2012 -0500 @@ -121,13 +121,6 @@ fun default (_, x, st) = (x, st) -structure SS = BinarySetFn(struct - type ord_key = string - val compare = String.compare - end) - -val mayNotSpec = ref SS.empty - val functionInside = U.Con.exists {kind = fn _ => false, con = fn TFun _ => true | CFfi ("Basis", "transaction") => true @@ -351,6 +344,12 @@ val fxs' = map (squish (IS.listItems fvs)) fxs val p_bool = Print.PD.string o Bool.toString + + fun bumpCount n = + if IS.member (#specialized st, f) then + n + else + 5 + 2 *n in (*Print.prefaces "Func" [("name", Print.PD.string name), ("e", CorePrint.p_exp CoreEnv.empty e), @@ -359,8 +358,7 @@ orelse List.all (fn (ERel _, _) => true | _ => false) fxs' orelse List.exists (not o valueish) fxs' - orelse (IS.numItems fvs >= length fxs - andalso IS.exists (fn n => functionInside (#2 (List.nth (env, n)))) fvs) then + orelse IS.numItems fvs >= bumpCount (length fxs) then ((*Print.prefaces "No" [("name", Print.PD.string name), ("f", Print.PD.string (Int.toString f)), ("fxs'", @@ -373,9 +371,8 @@ andalso IS.exists (fn n => functionInside (#2 (List.nth (env, n)))) fvs))];*) default ()) else - case (KM.find (args, (vts, fxs')), - SS.member (!mayNotSpec, name) (*orelse IS.member (#specialized st, f)*)) of - (SOME f', _) => + case KM.find (args, (vts, fxs')) of + SOME f' => let val e = (ENamed f', loc) val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc)) @@ -387,16 +384,14 @@ [("e'", CorePrint.p_exp CoreEnv.empty e)];*) (e, st) end - | (_, true) => ((*Print.prefaces ("No!(" ^ name ^ ")") - [("fxs'", - Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*) - default ()) - | (NONE, false) => + | NONE => let (*val () = Print.prefaces "New one" - [("f", Print.PD.string (Int.toString f)), - ("mns", Print.p_list Print.PD.string - (SS.listItems (!mayNotSpec)))]*) + [("name", Print.PD.string name), + ("f", Print.PD.string (Int.toString f)), + ("|fvs|", Print.PD.string (Int.toString (IS.numItems fvs))), + ("|fxs|", Print.PD.string (Int.toString (length fxs))), + ("spec", Print.PD.string (Bool.toString (IS.member (#specialized st, f))))]*) (*val () = Print.prefaces ("Yes(" ^ name ^ ")") [("fxs'", @@ -450,13 +445,10 @@ (TFun (xt, typ'), loc)) end) (body', typ') fvs - val mns = !mayNotSpec - (*val () = mayNotSpec := SS.add (mns, name)*) (*val () = print ("NEW: " ^ name ^ "__" ^ Int.toString f' ^ "\n");*) val body' = ReduceLocal.reduceExp body' (*val () = Print.preface ("PRE", CorePrint.p_exp CoreEnv.empty body')*) val (body', st) = exp (env, body', st) - val () = mayNotSpec := mns val e' = (ENamed f', loc) val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc)) @@ -503,8 +495,6 @@ (*val () = Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)]*) - val () = mayNotSpec := SS.empty - val (d', st) = if isPoly d then (d, st) @@ -536,7 +526,6 @@ val (vis, st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) => let - val () = mayNotSpec := SS.empty val (e, st) = exp ([], e, st) in ((x, n, t, e, s), st) @@ -566,8 +555,6 @@ end | _ => (d, st) - val () = mayNotSpec := SS.empty - (*val () = print "/decl\n"*) val funcs = #funcs st