summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-10-25 12:08:21 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-10-25 12:08:21 -0400
commitd04337d2e0319d56ac5f7ed2b4d431cb56017bb5 (patch)
treeec15a07fb2f89e4a678549904dd3c4ad9bec434d /src
parent5e9435290876dcdfd3c66fb652257f4c3ed50697 (diff)
Inlining threshold for Reduce
Diffstat (limited to 'src')
-rw-r--r--src/reduce.sml55
-rw-r--r--src/settings.sig6
-rw-r--r--src/settings.sml8
-rw-r--r--src/unpoly.sml19
4 files changed, 77 insertions, 11 deletions
diff --git a/src/reduce.sml b/src/reduce.sml
index c2becb2b..59ec565a 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -31,6 +31,7 @@ structure Reduce :> REDUCE = struct
open Core
+structure IS = IntBinarySet
structure IM = IntBinaryMap
structure E = CoreEnv
@@ -814,7 +815,33 @@ fun exp (namedC, namedE) env e = #exp (kindConAndExp (namedC, namedE)) env e
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 @@ fun reduce file =
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 @@ fun reduce file =
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 @@ fun reduce file =
| 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
diff --git a/src/settings.sig b/src/settings.sig
index a207b207..61095ff8 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -175,4 +175,10 @@ signature SETTINGS = sig
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
diff --git a/src/settings.sml b/src/settings.sml
index b7bc02ff..300bbf2c 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -402,4 +402,12 @@ val sql = ref (NONE : string option)
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
diff --git a/src/unpoly.sml b/src/unpoly.sml
index 6f838392..14ab4563 100644
--- a/src/unpoly.sml
+++ b/src/unpoly.sml
@@ -162,12 +162,19 @@ fun exp (e, st : state) =
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)