diff options
| author |  Adam Chlipala <adam@chlipala.net> | 2013-08-09 16:04:16 -0400 |
|---|---|---|
| committer | Adam Chlipala <adam@chlipala.net> | 2013-08-09 16:04:16 -0400 |
| commit | bdf86255666b015da22dbd7f4c96f54869608f22 (patch) | |
| tree | 6a5af50104e10e75d2fdf157b350d0a7934782f3 | |
| parent | d0f5e6a7ef66c2a4d9f37ac464e36f69687b8132 (diff) | |
Extend Especialize rule: find maximal argument prefixes that end in 1 or more arguments with functional types
| -rw-r--r-- | src/especialize.sml | 54 |
1 files changed, 35 insertions, 19 deletions
diff --git a/src/especialize.sml b/src/especialize.sml index 51e15a2d..dac91535 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -364,30 +364,42 @@ fun specialize' (funcs, specialized) file = let val (xs, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st xs - (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty - (e, ErrorMsg.dummySpan))]*) + (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty e)]*) val loc = ErrorMsg.dummySpan val oldXs = xs - fun findSplit av (constArgs, xs, typ, fxs, fvs) = - case (#1 typ, xs) of - (TFun (dom, ran), e :: xs') => - if constArgs > 0 then - if functionInside dom then - (rev (e :: fxs), xs', IS.union (fvs, freeVars e)) + fun findSplit av (initialPart, constArgs, xs, typ, fxs, fvs) = + let + fun default () = + if initialPart then + ([], oldXs, IS.empty) else - findSplit av (constArgs - 1, - xs', - ran, - e :: fxs, - IS.union (fvs, freeVars e)) - else - ([], oldXs, IS.empty) - | _ => ([], oldXs, IS.empty) + (rev fxs, xs, fvs) + in + case (#1 typ, xs) of + (TFun (dom, ran), e :: xs') => + if constArgs > 0 then + let + val fi = functionInside dom + in + if initialPart orelse fi then + findSplit av (not fi andalso initialPart, + constArgs - 1, + xs', + ran, + e :: fxs, + IS.union (fvs, freeVars e)) + else + default () + end + else + default () + | _ => default () + end - val (fxs, xs, fvs) = findSplit true (constArgs, xs, typ, [], IS.empty) + val (fxs, xs, fvs) = findSplit true (true, constArgs, xs, typ, [], IS.empty) val vts = map (fn n => #2 (List.nth (env, n))) (IS.listItems fvs) val fxs' = map (squish (IS.listItems fvs)) fxs @@ -483,7 +495,7 @@ fun specialize' (funcs, specialized) file = (TFun (xt, typ'), loc)) end) (body', typ') fvs - (*val () = print ("NEW: " ^ name ^ "__" ^ Int.toString f' ^ "\n");*) + (*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) @@ -523,6 +535,8 @@ fun specialize' (funcs, specialized) file = Int.min (constArgs, calcConstArgs fs e)) maxInt vis in + (*Print.prefaces "ConstArgs" [("d", CorePrint.p_decl CoreEnv.empty d), + ("ca", Print.PD.string (Int.toString constArgs))];*) foldl (fn ((x, n, c, e, tag), funcs) => IM.insert (funcs, n, {name = x, args = KM.empty, @@ -607,12 +621,14 @@ fun specialize' (funcs, specialized) file = val funcs = case #1 d of DVal (x, n, c, e as (EAbs _, _), tag) => + ((*Print.prefaces "ConstArgs[2]" [("d", CorePrint.p_decl CoreEnv.empty d), + ("ca", Print.PD.string (Int.toString (calcConstArgs (IS.singleton n) e)))];*) IM.insert (funcs, n, {name = x, args = KM.empty, body = e, typ = c, tag = tag, - constArgs = calcConstArgs (IS.singleton n) e}) + constArgs = calcConstArgs (IS.singleton n) e})) | DVal (_, n, _, (ENamed n', _), _) => (case IM.find (funcs, n') of NONE => funcs |