summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/main.mlton.sml3
-rw-r--r--src/settings.sig2
-rw-r--r--src/settings.sml4
-rw-r--r--src/sqlcache.sml95
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 ()