# HG changeset patch
# User Adam Chlipala <adamc@hcoop.net>
# Date 1256486901 14400
# Node ID 065ce32520906f062669918871fc4538b480b17d
# Parent  e47303e5d73db910e694079cdaabb5e9edf5faab
Inlining threshold for Reduce

diff -r e47303e5d73d -r 065ce3252090 src/reduce.sml
--- 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
diff -r e47303e5d73d -r 065ce3252090 src/settings.sig
--- 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
diff -r e47303e5d73d -r 065ce3252090 src/settings.sml
--- 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
diff -r e47303e5d73d -r 065ce3252090 src/unpoly.sml
--- 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)