# HG changeset patch # User Ziv Scully # Date 1447972187 18000 # Node ID 47d5c94aeeb82b7deaa08dc286afd3969da2a536 # Parent 6e580e31907786fcea8bc3db656e831884297c3f Add consolidation heuristic options. diff -r 6e580e319077 -r 47d5c94aeeb8 src/main.mlton.sml --- a/src/main.mlton.sml Thu Nov 19 16:02:04 2015 -0500 +++ b/src/main.mlton.sml Thu Nov 19 17:29:47 2015 -0500 @@ -162,6 +162,9 @@ | "-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 -r 6e580e319077 -r 47d5c94aeeb8 src/settings.sig --- a/src/settings.sig Thu Nov 19 16:02:04 2015 -0500 +++ b/src/settings.sig Thu Nov 19 17:29:47 2015 -0500 @@ -281,6 +281,8 @@ 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 -r 6e580e319077 -r 47d5c94aeeb8 src/settings.sml --- a/src/settings.sml Thu Nov 19 16:02:04 2015 -0500 +++ b/src/settings.sml Thu Nov 19 17:29:47 2015 -0500 @@ -811,6 +811,10 @@ 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 -r 6e580e319077 -r 47d5c94aeeb8 src/sqlcache.sml --- a/src/sqlcache.sml Thu Nov 19 16:02:04 2015 -0500 +++ b/src/sqlcache.sml Thu Nov 19 17:29:47 2015 -0500 @@ -93,9 +93,17 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 ()