From 75d1eedd15edc41b1c2bc9d1fce7a74f37bd78a1 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Tue, 14 Oct 2014 18:05:09 -0400 Subject: Complete overhaul: cache queries based on immediate query result, not eventual HTML output. --- src/settings.sml | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'src/settings.sml') diff --git a/src/settings.sml b/src/settings.sml index eb350c95..81c33c08 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -744,6 +744,10 @@ val less = ref false fun setLessSafeFfi b = less := b fun getLessSafeFfi () = !less +val sqlcache = ref false +fun setSqlcache b = sqlcache := b +fun getSqlcache () = !sqlcache + structure SM = BinaryMapFn(struct type ord_key = string val compare = String.compare -- cgit v1.2.3 From f1327b29e1c499845d13e01b4c1635d616713493 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Tue, 7 Apr 2015 14:18:53 -0400 Subject: New mouse events oncontextmenu, onmouseenter, and onmouseleave. --- lib/js/urweb.js | 12 ++++++++++++ lib/ur/basis.urs | 5 ++++- src/settings.sml | 11 ++++++++++- tests/docevents.ur | 7 ++++--- 4 files changed, 30 insertions(+), 5 deletions(-) (limited to 'src/settings.sml') diff --git a/lib/js/urweb.js b/lib/js/urweb.js index b599393b..335cb525 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -537,6 +537,10 @@ function uw_onClick(f) { uw_handler("onclick", f); } +function uw_onContextmenu(f) { + uw_handler("oncontextmenu", f); +} + function uw_onDblclick(f) { uw_handler("ondblclick", f); } @@ -545,6 +549,14 @@ function uw_onMousedown(f) { uw_handler("onmousedown", f); } +function uw_onMouseenter(f) { + uw_handler("onmouseenter", f); +} + +function uw_onMouseleave(f) { + uw_handler("onmouseleave", f); +} + function uw_onMousemove(f) { uw_handler("onmousemove", f); } diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index b8e52582..28384c2c 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -833,7 +833,7 @@ type mouseEvent = { ScreenX : int, ScreenY : int, ClientX : int, ClientY : int, Button : mouseButton } con mouseEvents = map (fn _ :: Unit => mouseEvent -> transaction unit) - [Onclick, Ondblclick, Onmousedown, Onmousemove, Onmouseout, Onmouseover, Onmouseup] + [Onclick, Oncontextmenu, Ondblclick, Onmousedown, Onmouseenter, Onmouseleave, Onmousemove, Onmouseout, Onmouseover, Onmouseup] type keyEvent = { KeyCode : int, CtrlKey : bool, ShiftKey : bool, AltKey : bool, MetaKey : bool } @@ -1120,10 +1120,13 @@ val onServerError : (string -> transaction unit) -> transaction unit (* More standard document-level JavaScript handlers *) val onClick : (mouseEvent -> transaction unit) -> transaction unit val onDblclick : (mouseEvent -> transaction unit) -> transaction unit +val onContextmenu : (mouseEvent -> transaction unit) -> transaction unit val onKeydown : (keyEvent -> transaction unit) -> transaction unit val onKeypress : (keyEvent -> transaction unit) -> transaction unit val onKeyup : (keyEvent -> transaction unit) -> transaction unit val onMousedown : (mouseEvent -> transaction unit) -> transaction unit +val onMouseenter : (mouseEvent -> transaction unit) -> transaction unit +val onMouseleave : (mouseEvent -> transaction unit) -> transaction unit val onMousemove : (mouseEvent -> transaction unit) -> transaction unit val onMouseout : (mouseEvent -> transaction unit) -> transaction unit val onMouseover : (mouseEvent -> transaction unit) -> transaction unit diff --git a/src/settings.sml b/src/settings.sml index bd958e22..e15988cd 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -176,10 +176,13 @@ val benignBase = basis ["get_cookie", "spawn", "onClick", "onDblclick", + "onContextmenu", "onKeydown", "onKeypress", "onKeyup", "onMousedown", + "onMouseenter", + "onMouseleave", "onMousemove", "onMouseout", "onMouseover", @@ -212,11 +215,14 @@ val clientBase = basis ["get_client_source", "mouseEvent", "keyEvent", "onClick", + "onContextmenu", "onDblclick", "onKeydown", "onKeypress", "onKeyup", "onMousedown", + "onMouseenter", + "onMouseleave", "onMousemove", "onMouseout", "onMouseover", @@ -349,11 +355,14 @@ val jsFuncsBase = basisM [("alert", "alert"), ("onClick", "uw_onClick"), + ("onContextmenu", "uw_onContextmenu"), ("onDblclick", "uw_onDblclick"), ("onKeydown", "uw_onKeydown"), ("onKeypress", "uw_onKeypress"), ("onKeyup", "uw_onKeyup"), ("onMousedown", "uw_onMousedown"), + ("onMouseenter", "uw_onMouseenter"), + ("onMouseleave", "uw_onMouseleave"), ("onMousemove", "uw_onMousemove"), ("onMouseout", "uw_onMouseout"), ("onMouseover", "uw_onMouseover"), @@ -764,7 +773,7 @@ fun mangleSqlTable s = fun mangleSql s = if #name (currentDbms ()) = "mysql" then if !mangle then - "uw_" ^ allLower s + "uw_" ^ allLower s else allLower s else diff --git a/tests/docevents.ur b/tests/docevents.ur index eed38868..906afa2b 100644 --- a/tests/docevents.ur +++ b/tests/docevents.ur @@ -1,6 +1,7 @@ fun main () : transaction page = return - alert ("Keypress: " ^ show k))}> + alert "Double click"); + onContextmenu (fn _ => alert "Context menu"); + onKeypress (fn k => alert ("Keypress: " ^ show k.KeyCode))}> Nothing here. - + -- cgit v1.2.3 From e86ed0717e35bea1ad6127d193e5979aec4841b9 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Wed, 14 Oct 2015 00:07:00 -0400 Subject: Hard-code Sqlcache module (in Ur/Web) as effectful and reorder sqlcache.sml. --- src/lru_cache.sml | 8 +- src/mono_fooify.sml | 2 - src/settings.sml | 3 +- src/sqlcache.sml | 478 +++++++++++++++++++++++++++------------------------- src/toy_cache.sml | 8 +- 5 files changed, 250 insertions(+), 249 deletions(-) (limited to 'src/settings.sml') diff --git a/src/lru_cache.sml b/src/lru_cache.sml index 275c3061..e69624d8 100644 --- a/src/lru_cache.sml +++ b/src/lru_cache.sml @@ -13,13 +13,7 @@ val optionStringTyp = (TOption stringTyp, dummyLoc) fun withTyp typ = map (fn exp => (exp, typ)) fun ffiAppCache' (func, index, argTyps) = - let - val m = "Sqlcache" - val f = func ^ Int.toString index - in - Settings.addEffectful (m, f); - EFfiApp (m, f, argTyps) - end + EFfiApp ("Sqlcache", func ^ Int.toString index, argTyps) fun check (index, keys) = ffiAppCache' ("check", index, withTyp stringTyp keys) diff --git a/src/mono_fooify.sml b/src/mono_fooify.sml index bbd34b15..e64207cd 100644 --- a/src/mono_fooify.sml +++ b/src/mono_fooify.sml @@ -167,7 +167,6 @@ fun fooifyExpWithExceptions fk lookupENamed lookupDatatype = case t of TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) | TFfi (m, x) => (if Settings.mayClientToServer (m, x) - (* TODO: better error message. (Then again, user should never see this.) *) then ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm) else raise CantPass (fm, tAll)) @@ -311,7 +310,6 @@ fun fooifyExp fk lookupENamed lookupDatatype fm exp = Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)]; (dummyExp, fm)) - (* Has to be set at the end of [Monoize]. *) val canonicalFm = ref (Fm.empty 0 : Fm.t) diff --git a/src/settings.sml b/src/settings.sml index ff99bf13..ecf353cd 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -151,7 +151,8 @@ val effectfulBase = basis ["dml", val effectful = ref effectfulBase fun setEffectful ls = effectful := S.addList (effectfulBase, ls) -fun isEffectful x = S.member (!effectful, x) +fun isEffectful ("Sqlcache", _) = true + | isEffectful x = S.member (!effectful, x) fun addEffectful x = effectful := S.add (!effectful, x) val benignBase = basis ["get_cookie", diff --git a/src/sqlcache.sml b/src/sqlcache.sml index f3db5795..1a4d4e97 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -15,7 +15,7 @@ fun iterate f n x = if n < 0 then x else iterate f (n-1) (f x) -(* Filled in by [cacheWrap] during [Sqlcache]. *) +(* Filled in by [cacheWrap]. *) val ffiInfo : {index : int, params : int} list ref = ref [] fun resetFfiInfo () = ffiInfo := [] @@ -41,8 +41,7 @@ val ffiEffectful = "urlifyBool_w", "urlifyChannel_w"] in - (* ASK: nicer way than using [Settings.addEffectful] for each Sqlcache - function? Right now they're all always effectful. *) + (* ASK: is it okay to hardcode Sqlcache functions as effectful? *) fn (m, f) => Settings.isEffectful (m, f) andalso not (m = "Basis" andalso SS.member (okayWrites, f)) end @@ -456,9 +455,9 @@ val tableDml = | Sql.Update (tab, _, _) => tab -(***************************) -(* Program Instrumentation *) -(***************************) +(*************************************) +(* Program Instrumentation Utilities *) +(*************************************) val varName = let @@ -496,33 +495,6 @@ fun incRels inc = bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound} 0 -fun cacheWrap (env, exp, resultTyp, args, i) = - let - val loc = dummyLoc - val rel0 = (ERel 0, loc) - in - case MonoFooify.urlify env (rel0, resultTyp) of - NONE => NONE - | SOME urlified => - let - val () = ffiInfo := {index = i, params = length args} :: !ffiInfo - (* We ensure before this step that all arguments aren't effectful. - by turning them into local variables as needed. *) - val argsInc = map (incRels 1) args - val check = (check (i, args), loc) - val store = (store (i, argsInc, urlified), loc) - in - SOME (ECase - (check, - [((PNone stringTyp, loc), - (ELet (varName "q", resultTyp, exp, (ESeq (store, rel0), loc)), loc)), - ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc), - (* Boolean is false because we're not unurlifying from a cookie. *) - (EUnurlify (rel0, resultTyp, false), loc))], - {disc = (TOption stringTyp, loc), result = resultTyp})) - end - end - fun fileTopLevelMapfoldB doTopLevelExp (decls, sideInfo) state = let fun doVal env ((x, n, t, exp, s), state) = @@ -570,205 +542,6 @@ fun fileAllMapfoldB doExp file start = fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ()) -fun factorOutNontrivial text = - let - val loc = dummyLoc - fun strcat (e1, e2) = (EStrcat (e1, e2), loc) - val chunks = Sql.chunkify text - val (newText, newVariables) = - (* Important that this is foldr (to oppose foldl below). *) - List.foldr - (fn (chunk, (qText, newVars)) => - (* Variable bound to the head of newBs will have the lowest index. *) - case chunk of - Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars) - | Sql.Exp e => - let - val n = length newVars - in - (* This is the (n+1)th new variable, so there are - already n new variables bound, so we increment - indices by n. *) - (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars) - end - | Sql.String s => (strcat (stringExp s, qText), newVars)) - (stringExp "", []) - chunks - fun wrapLets e' = - (* Important that this is foldl (to oppose foldr above). *) - List.foldl (fn (v, e') => ELet (varName "sqlArg", stringTyp, v, (e', loc))) - e' - newVariables - val numArgs = length newVariables - in - (newText, wrapLets, numArgs) - end - -fun cacheQuery effs env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) = - fn e' as EQuery {query = origQueryText, - state = resultTyp, - initial, body, tables, exps} => - let - val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText - (* Increment once for each new variable just made. *) - val queryExp = incRels numArgs - (EQuery {query = newQueryText, - state = resultTyp, - initial = initial, - body = body, - tables = tables, - exps = exps}, - dummyLoc) - (* DEBUG *) - (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *) - val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc)) - fun bind x f = Option.mapPartial f x - fun guard b x = if b then x else NONE - (* We use dummyTyp here. I think this is okay because databases don't - store (effectful) functions, but perhaps there's some pathalogical - corner case missing.... *) - fun safe bound = - not - o effectful effs - (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE) - bound - env) - val textOfQuery = fn (EQuery {query, ...}, _) => SOME query | _ => NONE - val attempt = - (* Ziv misses Haskell's do notation.... *) - bind (textOfQuery queryExp) (fn queryText => - guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) ( - bind (Sql.parse Sql.query queryText) (fn queryParsed => - bind (cacheWrap (env, queryExp, resultTyp, args, index)) (fn cachedExp => - SOME (wrapLets cachedExp, - (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index)) - tableToIndices - (tablesQuery queryParsed), - IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)), - index + 1)))))) - in - case attempt of - SOME pair => pair - (* We have to increment index conservatively. *) - (* TODO: just use a reference for current index.... *) - | NONE => (e', (tableToIndices, indexToQueryNumArgs, index + 1)) - end - | e' => (e', queryInfo) - -fun addChecking file = - let - val effs = effectfulDecls file - in - (fileAllMapfoldB (fn env => fn exp => fn state => cacheQuery effs env state exp) - file - (SIMM.empty, IM.empty, 0), - effs) - end - -structure Invalidations = struct - - val loc = dummyLoc - - val optionAtomExpToExp = - fn NONE => (ENone stringTyp, loc) - | SOME e => (ESome (stringTyp, - (case e of - DmlRel n => ERel n - | Prim p => EPrim p - (* TODO: make new type containing only these two. *) - | _ => raise Match, - loc)), - loc) - - fun eqsToInvalidation numArgs eqs = - let - fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1) - in - inv (numArgs - 1) - end - - (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here - represents unknown, which means a wider invalidation. *) - val rec madeRedundantBy : atomExp option list * atomExp option list -> bool = - fn ([], []) => true - | (_ :: xs, NONE :: ys) => madeRedundantBy (xs, ys) - | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of - EQUAL => madeRedundantBy (xs, ys) - | _ => false) - | _ => false - - fun eqss (query, dml) = conflictMaps (queryToFormula query, dmlToFormula dml) - - fun invalidations ((query, numArgs), dml) = - (map (map optionAtomExpToExp) - o removeRedundant madeRedundantBy - o map (eqsToInvalidation numArgs) - o eqss) - (query, dml) - -end - -val invalidations = Invalidations.invalidations - -(* DEBUG *) -(* val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] *) -(* val gunk' : exp list ref = ref [] *) - -fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) = - let - val flushes = List.concat - o map (fn (i, argss) => map (fn args => flush (i, args)) argss) - val doExp = - fn EDml (origDmlText, failureMode) => - let - (* DEBUG *) - (* val () = gunk' := origDmlText :: !gunk' *) - val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText - val dmlText = incRels numArgs newDmlText - val dmlExp = EDml (dmlText, failureMode) - (* DEBUG *) - val () = Print.preface ("SQLCACHE: ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) - val inval = - case Sql.parse Sql.dml dmlText of - SOME dmlParsed => - SOME (map (fn i => (case IM.find (indexToQueryNumArgs, i) of - SOME queryNumArgs => - (* DEBUG *) - ((* gunk := (queryNumArgs, dmlParsed) :: !gunk; *) - (i, invalidations (queryNumArgs, dmlParsed))) - (* TODO: fail more gracefully. *) - | NONE => raise Match)) - (SIMM.findList (tableToIndices, tableDml dmlParsed))) - | NONE => NONE - in - case inval of - (* TODO: fail more gracefully. *) - NONE => raise Match - | SOME invs => wrapLets (sequence (flushes invs @ [dmlExp])) - end - | e' => e' - in - (* DEBUG *) - (* gunk := []; *) - (fileMap doExp file, index, effs) - end - -val inlineSql = - let - val doExp = - (* TODO: EQuery, too? *) - (* ASK: should this live in [MonoOpt]? *) - fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) => - let - val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases - in - ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)}) - end - | e => e - in - fileMap doExp - end - (**********************) (* Mono Type Checking *) @@ -830,6 +603,33 @@ and typOfExp env (e', loc) = typOfExp' env e' (* Caching Pure Subexpressions *) (*******************************) +fun cacheWrap (env, exp, resultTyp, args, i) = + let + val loc = dummyLoc + val rel0 = (ERel 0, loc) + in + case MonoFooify.urlify env (rel0, resultTyp) of + NONE => NONE + | SOME urlified => + let + val () = ffiInfo := {index = i, params = length args} :: !ffiInfo + (* We ensure before this step that all arguments aren't effectful. + by turning them into local variables as needed. *) + val argsInc = map (incRels 1) args + val check = (check (i, args), loc) + val store = (store (i, argsInc, urlified), loc) + in + SOME (ECase + (check, + [((PNone stringTyp, loc), + (ELet (varName "q", resultTyp, exp, (ESeq (store, rel0), loc)), loc)), + ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc), + (* Boolean is false because we're not unurlifying from a cookie. *) + (EUnurlify (rel0, resultTyp, false), loc))], + {disc = (TOption stringTyp, loc), result = resultTyp})) + end + end + val freeVars = IS.listItems o MonoUtil.Exp.foldB @@ -1005,6 +805,220 @@ fun addPure (file, indexStart, effs) = #1 (fileTopLevelMapfoldB doTopLevelExp file indexStart) end + +(***********************) +(* Caching SQL Queries *) +(***********************) + +fun factorOutNontrivial text = + let + val loc = dummyLoc + fun strcat (e1, e2) = (EStrcat (e1, e2), loc) + val chunks = Sql.chunkify text + val (newText, newVariables) = + (* Important that this is foldr (to oppose foldl below). *) + List.foldr + (fn (chunk, (qText, newVars)) => + (* Variable bound to the head of newBs will have the lowest index. *) + case chunk of + Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars) + | Sql.Exp e => + let + val n = length newVars + in + (* This is the (n+1)th new variable, so there are + already n new variables bound, so we increment + indices by n. *) + (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars) + end + | Sql.String s => (strcat (stringExp s, qText), newVars)) + (stringExp "", []) + chunks + fun wrapLets e' = + (* Important that this is foldl (to oppose foldr above). *) + List.foldl (fn (v, e') => ELet (varName "sqlArg", stringTyp, v, (e', loc))) + e' + newVariables + val numArgs = length newVariables + in + (newText, wrapLets, numArgs) + end + +fun cacheQuery effs env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) = + fn e' as EQuery {query = origQueryText, + state = resultTyp, + initial, body, tables, exps} => + let + val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText + (* Increment once for each new variable just made. *) + val queryExp = incRels numArgs + (EQuery {query = newQueryText, + state = resultTyp, + initial = initial, + body = body, + tables = tables, + exps = exps}, + dummyLoc) + (* DEBUG *) + (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *) + val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc)) + fun bind x f = Option.mapPartial f x + fun guard b x = if b then x else NONE + (* We use dummyTyp here. I think this is okay because databases don't + store (effectful) functions, but perhaps there's some pathalogical + corner case missing.... *) + fun safe bound = + not + o effectful effs + (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE) + bound + env) + val textOfQuery = fn (EQuery {query, ...}, _) => SOME query | _ => NONE + val attempt = + (* Ziv misses Haskell's do notation.... *) + bind (textOfQuery queryExp) (fn queryText => + guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) ( + bind (Sql.parse Sql.query queryText) (fn queryParsed => + bind (cacheWrap (env, queryExp, resultTyp, args, index)) (fn cachedExp => + SOME (wrapLets cachedExp, + (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index)) + tableToIndices + (tablesQuery queryParsed), + IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)), + index + 1)))))) + in + case attempt of + SOME pair => pair + (* We have to increment index conservatively. *) + (* TODO: just use a reference for current index.... *) + | NONE => (e', (tableToIndices, indexToQueryNumArgs, index + 1)) + end + | e' => (e', queryInfo) + +fun addChecking file = + let + val effs = effectfulDecls file + in + (fileAllMapfoldB (fn env => fn exp => fn state => cacheQuery effs env state exp) + file + (SIMM.empty, IM.empty, 0), + effs) + end + + +(************) +(* Flushing *) +(************) + +structure Invalidations = struct + + val loc = dummyLoc + + val optionAtomExpToExp = + fn NONE => (ENone stringTyp, loc) + | SOME e => (ESome (stringTyp, + (case e of + DmlRel n => ERel n + | Prim p => EPrim p + (* TODO: make new type containing only these two. *) + | _ => raise Match, + loc)), + loc) + + fun eqsToInvalidation numArgs eqs = + let + fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1) + in + inv (numArgs - 1) + end + + (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here + represents unknown, which means a wider invalidation. *) + val rec madeRedundantBy : atomExp option list * atomExp option list -> bool = + fn ([], []) => true + | (_ :: xs, NONE :: ys) => madeRedundantBy (xs, ys) + | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of + EQUAL => madeRedundantBy (xs, ys) + | _ => false) + | _ => false + + fun eqss (query, dml) = conflictMaps (queryToFormula query, dmlToFormula dml) + + fun invalidations ((query, numArgs), dml) = + (map (map optionAtomExpToExp) + o removeRedundant madeRedundantBy + o map (eqsToInvalidation numArgs) + o eqss) + (query, dml) + +end + +val invalidations = Invalidations.invalidations + +(* DEBUG *) +(* val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] *) +(* val gunk' : exp list ref = ref [] *) + +fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) = + let + val flushes = List.concat + o map (fn (i, argss) => map (fn args => flush (i, args)) argss) + val doExp = + fn EDml (origDmlText, failureMode) => + let + (* DEBUG *) + (* val () = gunk' := origDmlText :: !gunk' *) + val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText + val dmlText = incRels numArgs newDmlText + val dmlExp = EDml (dmlText, failureMode) + (* DEBUG *) + (* val () = Print.preface ("SQLCACHE: ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) *) + val inval = + case Sql.parse Sql.dml dmlText of + SOME dmlParsed => + SOME (map (fn i => (case IM.find (indexToQueryNumArgs, i) of + SOME queryNumArgs => + (* DEBUG *) + ((* gunk := (queryNumArgs, dmlParsed) :: !gunk; *) + (i, invalidations (queryNumArgs, dmlParsed))) + (* TODO: fail more gracefully. *) + | NONE => raise Match)) + (SIMM.findList (tableToIndices, tableDml dmlParsed))) + | NONE => NONE + in + case inval of + (* TODO: fail more gracefully. *) + NONE => raise Match + | SOME invs => wrapLets (sequence (flushes invs @ [dmlExp])) + end + | e' => e' + in + (* DEBUG *) + (* gunk := []; *) + (fileMap doExp file, index, effs) + end + + +(***************) +(* Entry point *) +(***************) + +val inlineSql = + let + val doExp = + (* TODO: EQuery, too? *) + (* ASK: should this live in [MonoOpt]? *) + fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) => + let + val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases + in + ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)}) + end + | e => e + in + fileMap doExp + end + fun insertAfterDatatypes ((decls, sideInfo), newDecls) = let val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls diff --git a/src/toy_cache.sml b/src/toy_cache.sml index cfde027b..377cae01 100644 --- a/src/toy_cache.sml +++ b/src/toy_cache.sml @@ -13,13 +13,7 @@ val optionStringTyp = (TOption stringTyp, dummyLoc) fun withTyp typ = map (fn exp => (exp, typ)) fun ffiAppCache' (func, index, argTyps) = - let - val m = "Sqlcache" - val f = func ^ Int.toString index - in - Settings.addEffectful (m, f); - EFfiApp (m, f, argTyps) - end + EFfiApp ("Sqlcache", func ^ Int.toString index, argTyps) fun check (index, keys) = ffiAppCache' ("check", index, withTyp stringTyp keys) -- cgit v1.2.3 From 94b1dbce1ae20ded6b2e8cc519f56ac9e3b39b24 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Thu, 19 Nov 2015 17:29:47 -0500 Subject: Add consolidation heuristic options. --- src/main.mlton.sml | 3 ++ src/settings.sig | 2 ++ src/settings.sml | 4 +++ src/sqlcache.sml | 95 +++++++++++++++++++++++++++++------------------------- 4 files changed, 60 insertions(+), 44 deletions(-) (limited to 'src/settings.sml') 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 () -- cgit v1.2.3 From a0d66adaeceaa07e4006a0570211f7453a5b5738 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Fri, 20 Nov 2015 03:26:21 -0500 Subject: Tweak cache consolidation and choose better default. --- src/main.mlton.sml | 2 +- src/settings.sig | 2 -- src/settings.sml | 4 ---- src/sqlcache.sig | 2 ++ src/sqlcache.sml | 40 +++++++++++++++++++++------------------- 5 files changed, 24 insertions(+), 26 deletions(-) (limited to 'src/settings.sml') diff --git a/src/main.mlton.sml b/src/main.mlton.sml index d3d88af9..164ddfbd 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -163,7 +163,7 @@ fun oneRun args = (Settings.setSqlcache true; doArgs rest) | "-heuristic" :: h :: rest => - (Settings.setSqlcacheHeuristic h; + (Sqlcache.setHeuristic h; doArgs rest) | "-moduleOf" :: fname :: _ => (print (Compiler.moduleOf fname ^ "\n"); diff --git a/src/settings.sig b/src/settings.sig index d4bb4b08..e94832e0 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -281,8 +281,6 @@ 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 073e7883..f9125c64 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -811,10 +811,6 @@ 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.sig b/src/sqlcache.sig index fabc9ebf..e264c1f0 100644 --- a/src/sqlcache.sig +++ b/src/sqlcache.sig @@ -3,6 +3,8 @@ signature SQLCACHE = sig val setCache : Cache.cache -> unit val getCache : unit -> Cache.cache +val setHeuristic : string -> unit + val getFfiInfo : unit -> {index : int, params : int} list val go : Mono.file -> Mono.file diff --git a/src/sqlcache.sml b/src/sqlcache.sml index b2c8504b..75a17e48 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -93,12 +93,11 @@ val cacheRef = ref LruCache.cache fun setCache c = cacheRef := c fun getCache () = !cacheRef -datatype heuristic = SmartEq (* | SmartSub *) | Always | Never | NoPureAll | NoPureOne | NoCombo +datatype heuristic = Smart | Always | Never | NoPureAll | NoPureOne | NoCombo -val heuristicRef = ref Always +val heuristicRef = ref NoPureOne fun setHeuristic h = heuristicRef := (case h of - "smarteq" => SmartEq - (* | "smartsub" => SmartSub *) + "smart" => Smart | "always" => Always | "never" => Never | "nopureall" => NoPureAll @@ -498,6 +497,7 @@ end = struct structure I = SK structure J = SK structure K = struct type ord_key = Mono.typ val compare = MonoUtil.Typ.compare end))) + structure AS = BinarySetFn(AK) structure AM = BinaryMapFn(AK) (* Traversal Utilities *) @@ -615,13 +615,16 @@ end = struct val union = op@ - fun addToSqlArgsMap ((q, subst), acc) = - IM.foldl (fn (arg, acc) => AM.insert (acc, arg, ())) acc subst + fun sqlArgsSet (q, subst) = + IM.foldl AS.add' AS.empty subst fun sqlArgsMap (qs : t) = let val args = - List.foldl addToSqlArgsMap AM.empty qs + List.foldl (fn ((q, subst), acc) => + IM.foldl (fn (arg, acc) => AM.insert (acc, arg, ())) acc subst) + AM.empty + qs val countRef = ref (~1) fun count () = (countRef := !countRef + 1; !countRef) in @@ -649,25 +652,26 @@ end = struct val pureArgs = PS.difference (paths, invalPaths) val shouldCache = case getHeuristic () of - SmartEq => + Smart => (case (qs, PS.numItems pureArgs) of ((q::qs), 0) => let - val m = addToSqlArgsMap (q, AM.empty) - val ms = map (fn q => addToSqlArgsMap (q, AM.empty)) qs - fun test (m, acc) = + val args = sqlArgsSet q + val argss = map sqlArgsSet qs + fun test (args, acc) = acc <\obind\> - (fn m' => + (fn args' => let - val mm = AM.unionWith #1 (m, m') + val both = AS.union (args, args') in - AM.numItems m = AM.numItems mm + (AS.numItems args = AS.numItems both + orelse AS.numItems args' = AS.numItems both) <\oguard\> - (fn _ => SOME mm) + (fn _ => SOME both) end) in - case List.foldl test (SOME m) ms of + case List.foldl test (SOME args) argss of NONE => false | SOME _ => true end @@ -1714,9 +1718,7 @@ 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; - setHeuristic (Settings.getSqlcacheHeuristic ())) + val () = (resetFfiInfo (); Sql.sqlcacheMode := true) val file = go' file (* Important that this happens after [MonoFooify.urlify] calls! *) val fmDecls = MonoFooify.getNewFmDecls () -- cgit v1.2.3