Add consolidation heuristic options.

4 files changed, 60 insertions, 44 deletions

diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index 3ae968b0..d3d88af9 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -162,6 +162,9 @@ fun oneRun args =
               | "-sqlcache" :: rest =>
                 (Settings.setSqlcache true;
                  doArgs rest)
+              | "-heuristic" :: h :: rest =>
+                (Settings.setSqlcacheHeuristic h;
+                 doArgs rest)
               | "-moduleOf" :: fname :: _ =>
                 (print (Compiler.moduleOf fname ^ "\n");
                  raise Code OS.Process.success)
diff --git a/src/settings.sig b/src/settings.sig
index e94832e0..d4bb4b08 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -281,6 +281,8 @@ signature SETTINGS = sig
 
     val setSqlcache : bool -> unit
     val getSqlcache : unit -> bool
+    val setSqlcacheHeuristic : string -> unit
+    val getSqlcacheHeuristic : unit -> string
 
     val setFilePath : string -> unit
     (* Sets the directory where we look for files being added below. *)
diff --git a/src/settings.sml b/src/settings.sml
index f9125c64..073e7883 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -811,6 +811,10 @@ val sqlcache = ref false
 fun setSqlcache b = sqlcache := b
 fun getSqlcache () = !sqlcache
 
+val sqlcacheHeuristic = ref "always"
+fun setSqlcacheHeuristic h = sqlcacheHeuristic := h
+fun getSqlcacheHeuristic () = !sqlcacheHeuristic
+
 structure SM = BinaryMapFn(struct
                            type ord_key = string
                            val compare = String.compare
diff --git a/src/sqlcache.sml b/src/sqlcache.sml
index ce5ad5f5..312ee217 100644
--- a/src/sqlcache.sml
+++ b/src/sqlcache.sml
@@ -93,9 +93,17 @@ val cacheRef = ref LruCache.cache
 fun setCache c = cacheRef := c
 fun getCache () = !cacheRef
 
-val alwaysConsolidateRef = ref true
-fun setAlwaysConsolidate b = alwaysConsolidateRef := b
-fun getAlwaysConsolidate () = !alwaysConsolidateRef
+datatype heuristic = Always | Never | NoPureAll | NoPureOne | NoCombo
+
+val heuristicRef = ref Always
+fun setHeuristic h = heuristicRef := (case h of
+                                          "always" => Always
+                                        | "never" => Never
+                                        | "nopureall" => NoPureAll
+                                        | "nopureone" => NoPureOne
+                                        | "nocombo" => NoCombo
+                                        | _ => raise Fail "Sqlcache: setHeuristic")
+fun getHeuristic () = !heuristicRef
 
 
 (************************)
@@ -463,7 +471,7 @@ structure InvalInfo :> sig
     val empty : t
     val singleton : Sql.query -> t
     val query : t -> Sql.query
-    val orderArgs : t * Mono.exp -> cacheArg list
+    val orderArgs : t * Mono.exp -> cacheArg list option
     val unbind : t * unbind -> t option
     val union : t * t -> t
     val updateState : t * int * state -> state
@@ -635,11 +643,20 @@ end = struct
             val argsMap = sqlArgsMap qs
             val args = map (expOfArg o #1) (AM.listItemsi argsMap)
             val invalPaths = List.foldl PS.union PS.empty (map freePaths args)
+            (* TODO: make sure these variables are okay to remove from the argument list. *)
+            val pureArgs = PS.difference (paths, invalPaths)
+            val shouldCache =
+                case getHeuristic () of
+                    Always => true
+                  | Never => (case qs of [_] => true | _ => false)
+                  | NoPureAll => (case qs of [] => false | _ => true)
+                  | NoPureOne => (case qs of [] => false | _ => PS.numItems pureArgs = 0)
+                  | NoCombo => PS.numItems pureArgs = 0 orelse AM.numItems argsMap = 0
         in
             (* Put arguments we might invalidate by first. *)
-            map AsIs args
-            (* TODO: make sure these variables are okay to remove from the argument list. *)
-            @ map (Urlify o expOfPath) (PS.listItems (PS.difference (paths, invalPaths)))
+            if shouldCache
+            then SOME (map AsIs args @ map (Urlify o expOfPath) (PS.listItems pureArgs))
+            else NONE
         end
 
     (* As a kludge, we rename the variables in the query to correspond to the
@@ -1309,47 +1326,35 @@ val worthCaching =
  fn EQuery _ => true
   | exp' => expSize (exp', dummyLoc) > sizeWorthCaching
 
-fun shouldConsolidate args =
-    let
-        val isAsIs = fn AsIs _ => true | Urlify _ => false
-    in
-        getAlwaysConsolidate ()
-        orelse not (List.exists isAsIs args andalso List.exists (not o isAsIs) args)
-    end
-
 fun cacheExp (env, exp', invalInfo, state : state) =
     case worthCaching exp' <\oguard\> (fn _ => typOfExp' env exp') of
         NONE => NONE
       | SOME (TFun _, _) => NONE
       | SOME typ =>
-        let
-            val args = InvalInfo.orderArgs (invalInfo, (exp', dummyLoc))
-        in
-            shouldConsolidate args
-            <\oguard\>
-             (fn _ =>
-                 List.foldr (fn (arg, acc) =>
-                                acc
-                                <\obind\>
-                                 (fn args' =>
-                                     (case arg of
-                                          AsIs exp => SOME exp
-                                        | Urlify exp =>
-                                          typOfExp env exp
-                                          <\obind\>
-                                           (fn typ => (MonoFooify.urlify env (exp, typ))))
-                                     <\obind\>
-                                      (fn arg' => SOME (arg' :: args'))))
-                            (SOME [])
-                            args
-                 <\obind\>
-                  (fn args' =>
-                      cacheWrap (env, (exp', dummyLoc), typ, args', #index state)
-                      <\obind\>
-                       (fn cachedExp =>
-                           SOME (cachedExp,
-                                 InvalInfo.updateState (invalInfo, length args', state)))))
-        end
+        InvalInfo.orderArgs (invalInfo, (exp', dummyLoc))
+        <\obind\>
+         (fn args =>
+             List.foldr (fn (arg, acc) =>
+                            acc
+                            <\obind\>
+                             (fn args' =>
+                                 (case arg of
+                                      AsIs exp => SOME exp
+                                    | Urlify exp =>
+                                      typOfExp env exp
+                                      <\obind\>
+                                       (fn typ => (MonoFooify.urlify env (exp, typ))))
+                                 <\obind\>
+                                  (fn arg' => SOME (arg' :: args'))))
+                        (SOME [])
+                        args
+             <\obind\>
+              (fn args' =>
+                  cacheWrap (env, (exp', dummyLoc), typ, args', #index state)
+                  <\obind\>
+                   (fn cachedExp =>
+                       SOME (cachedExp,
+                             InvalInfo.updateState (invalInfo, length args', state)))))
 
 fun cacheQuery (effs, env, q) : subexp =
     let
@@ -1684,7 +1689,9 @@ val go' = addLocking o addFlushing o addCaching o simplifySql o inlineSql
 fun go file =
     let
         (* TODO: do something nicer than [Sql] being in one of two modes. *)
-        val () = (resetFfiInfo (); Sql.sqlcacheMode := true)
+        val () = (resetFfiInfo ();
+                  Sql.sqlcacheMode := true;
+                  setHeuristic (Settings.getSqlcacheHeuristic ()))
         val file = go' file
         (* Important that this happens after [MonoFooify.urlify] calls! *)
         val fmDecls = MonoFooify.getNewFmDecls ()