Mercurial > urweb
changeset 1016:065ce3252090
Inlining threshold for Reduce
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 25 Oct 2009 12:08:21 -0400 |
| parents | e47303e5d73d |
| children | 34ba25d6af3b |
| files | src/reduce.sml src/settings.sig src/settings.sml src/unpoly.sml |
| diffstat | 4 files changed, 77 insertions(+), 11 deletions(-) [+] |
line wrap: on
line diff
--- a/src/reduce.sml Sun Oct 25 11:03:42 2009 -0400 +++ b/src/reduce.sml Sun Oct 25 12:08:21 2009 -0400 @@ -31,6 +31,7 @@ open Core +structure IS = IntBinarySet structure IM = IntBinaryMap structure E = CoreEnv @@ -814,7 +815,33 @@ fun reduce file = let - fun doDecl (d as (_, loc), st as (namedC, namedE)) = + val uses = CoreUtil.File.fold {kind = fn (_, m) => m, + con = fn (_, m) => m, + exp = fn (e, m) => + case e of + ENamed n => IM.insert (m, n, 1 + Option.getOpt (IM.find (m, n), 0)) + | _ => m, + decl = fn (_, m) => m} + IM.empty file + + fun isPoly names = CoreUtil.Con.exists {kind = fn _ => false, + con = fn TCFun _ => true + | TKFun _ => true + | CNamed n => IS.member (names, n) + | _ => false} + + val size = CoreUtil.Exp.fold {kind = fn (_, n) => n, + con = fn (_, n) => n, + exp = fn (_, n) => n + 1} 0 + + fun mayInline (polyC, n, t, e) = + case IM.find (uses, n) of + NONE => false + | SOME count => count <= 1 + orelse isPoly polyC t + orelse size e <= Settings.getCoreInline () + + fun doDecl (d as (_, loc), st as (polyC, namedC, namedE)) = case #1 d of DCon (x, n, k, c) => let @@ -822,7 +849,12 @@ val c = con namedC [] c in ((DCon (x, n, k, c), loc), - (IM.insert (namedC, n, c), namedE)) + (if isPoly polyC c then + IS.add (polyC, n) + else + polyC, + IM.insert (namedC, n, c), + namedE)) end | DDatatype dts => ((DDatatype (map (fn (x, n, ps, cs) => @@ -831,14 +863,27 @@ in (x, n, ps, map (fn (x, n, co) => (x, n, Option.map (con namedC env) co)) cs) end) dts), loc), - st) + (if List.exists (fn (_, _, _, cs) => List.exists (fn (_, _, co) => case co of + NONE => false + | SOME c => isPoly polyC c) cs) + dts then + foldl (fn ((_, n, _, _), polyC) => IS.add (polyC, n)) polyC dts + else + polyC, + namedC, + namedE)) | DVal (x, n, t, e, s) => let val t = con namedC [] t val e = exp (namedC, namedE) [] e in ((DVal (x, n, t, e, s), loc), - (namedC, IM.insert (namedE, n, e))) + (polyC, + namedC, + if mayInline (polyC, n, t, e) then + IM.insert (namedE, n, e) + else + namedE)) end | DValRec vis => ((DValRec (map (fn (x, n, t, e, s) => (x, n, con namedC [] t, @@ -856,7 +901,7 @@ | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st) | DStyle (s, n, s') => ((DStyle (s, n, s'), loc), st) - val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty) file + val (file, _) = ListUtil.foldlMap doDecl (IS.empty, IM.empty, IM.empty) file in file end
--- a/src/settings.sig Sun Oct 25 11:03:42 2009 -0400 +++ b/src/settings.sig Sun Oct 25 12:08:21 2009 -0400 @@ -175,4 +175,10 @@ val setSql : string option -> unit val getSql : unit -> string option + val setCoreInline : int -> unit + val getCoreInline : unit -> int + + val setMonoInline : int -> unit + val getMonoInline : unit -> int + end
--- a/src/settings.sml Sun Oct 25 11:03:42 2009 -0400 +++ b/src/settings.sml Sun Oct 25 12:08:21 2009 -0400 @@ -402,4 +402,12 @@ fun setSql so = sql := so fun getSql () = !sql +val coreInline = ref 20 +fun setCoreInline n = coreInline := n +fun getCoreInline () = !coreInline + +val monoInline = ref 20 +fun setMonoInline n = monoInline := n +fun getMonoInline () = !monoInline + end
--- a/src/unpoly.sml Sun Oct 25 11:03:42 2009 -0400 +++ b/src/unpoly.sml Sun Oct 25 12:08:21 2009 -0400 @@ -162,12 +162,19 @@ val vis' = map (fn (x, n, _, t, e, s) => (x, n, t, e, s)) vis - val funcs = IM.insert (#funcs st, n, - {kinds = ks, - defs = old_vis, - replacements = M.insert (replacements, - cargs, - thisName)}) + val funcs = foldl (fn ((_, n, n_old, _, _, _), funcs) => + let + val replacements = case IM.find (funcs, n_old) of + NONE => M.empty + | SOME {replacements = r, ...} => r + in + IM.insert (funcs, n_old, + {kinds = ks, + defs = old_vis, + replacements = M.insert (replacements, + cargs, + n)}) + end) (#funcs st) vis val ks' = List.drop (ks, length cargs)