Mercurial > urweb
changeset 2269:f7bc7c11a656
Make SQL caches use more of the pure caching machinery, but it's brittle.
| author | Ziv Scully <ziv@mit.edu> |
|---|---|
| date | Thu, 15 Oct 2015 00:52:04 -0400 |
| parents | bc1ef958d801 |
| children | 1e3ba868f8bf |
| files | caching-tests/test.ur caching-tests/test.urs src/sqlcache.sml |
| diffstat | 3 files changed, 46 insertions(+), 35 deletions(-) [+] |
line wrap: on
line diff
--- a/caching-tests/test.ur Wed Oct 14 23:10:10 2015 -0400 +++ b/caching-tests/test.ur Thu Oct 15 00:52:04 2015 -0400 @@ -11,6 +11,17 @@ | Some row => <xml>{[row.Tab.Val]}</xml>} </body></xml> +fun cache2 id v = + res <- oneOrNoRows (SELECT tab.Val + FROM tab + WHERE tab.Id = {[id]} AND tab.Val = {[v]}); + return <xml><body> + Reading {[id]}. + {case res of + None => <xml>Nope, that's not it.</xml> + | Some _ => <xml>Hooray! You guessed it!</xml>} + </body></xml> + fun flush id = dml (UPDATE tab SET Val = Val * (Id + 2) / Val - 3
--- a/caching-tests/test.urs Wed Oct 14 23:10:10 2015 -0400 +++ b/caching-tests/test.urs Thu Oct 15 00:52:04 2015 -0400 @@ -1,3 +1,4 @@ val cache : int -> transaction page +val cache2 : int -> int -> transaction page val flush : int -> transaction page val flush17 : transaction page
--- a/src/sqlcache.sml Wed Oct 14 23:10:10 2015 -0400 +++ b/src/sqlcache.sml Thu Oct 15 00:52:04 2015 -0400 @@ -675,6 +675,7 @@ | ELet (s, t, e1, e2) => typOfExp (MonoEnv.pushERel env s t (SOME e1)) e2 | EClosure _ => NONE | EUnurlify (_, t, _) => SOME t + | EQuery {state, ...} => SOME state | _ => NONE and typOfExp env (e', loc) = typOfExp' env e' @@ -770,17 +771,35 @@ (* TODO: pick a number. *) val sizeWorthCaching = 5 +val worthCaching = + fn EQuery _ => true + | exp' => expSize (exp', dummyLoc) > sizeWorthCaching + +fun cachePure (env, exp', state as (_, _, _, index)) = + case (worthCaching exp') + </oguard/> + typOfExp' env exp' of + NONE => NONE + | SOME (TFun _, _) => NONE + | SOME typ => + (List.foldr (fn (_, NONE) => NONE + | ((n, typ), SOME args) => + (MonoFooify.urlify env ((ERel n, dummyLoc), typ)) + </obind/> + (fn arg => SOME (arg :: args))) + (SOME []) + (map (fn n => (n, #2 (MonoEnv.lookupERel env n))) + (ListMergeSort.sort op> (freeVars (exp', dummyLoc))))) + </obind/> + (fn args => cacheWrap (env, (exp', dummyLoc), typ, args, state)) + fun cacheQuery (effs, env, state, q) : (exp' * state) = let val (tableToIndices, indexToQueryNumArgs, ffiInfo, index) = state - val {query = queryText, - state = resultTyp, - initial, body, tables, exps} = q + val {query = queryText, initial, body, ...} = q val numArgs = maxFreeVar queryText + 1 - val queryExp = (EQuery q, dummyLoc) (* DEBUG *) (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *) - val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc)) (* 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.... *) @@ -790,6 +809,8 @@ (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE) bound env) + val {state = resultTyp, ...} = q + val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc)) val attempt = (* Ziv misses Haskell's do notation.... *) (safe 0 queryText andalso safe 0 initial andalso safe 2 body) @@ -797,7 +818,7 @@ Sql.parse Sql.query queryText </obind/> (fn queryParsed => - (cacheWrap (env, queryExp, resultTyp, args, state)) + (cachePure (env, EQuery q, state)) </obind/> (fn (cachedExp, state) => SOME (cachedExp, @@ -813,24 +834,6 @@ | NONE => (EQuery q, state) end -fun cachePure (env, exp', state as (_, _, _, index)) = - case (expSize (exp', dummyLoc) > sizeWorthCaching) - </oguard/> - typOfExp' env exp' of - NONE => NONE - | SOME (TFun _, _) => NONE - | SOME typ => - (List.foldr (fn (_, NONE) => NONE - | ((n, typ), SOME args) => - (MonoFooify.urlify env ((ERel n, dummyLoc), typ)) - </obind/> - (fn arg => SOME (arg :: args))) - (SOME []) - (map (fn n => (n, #2 (MonoEnv.lookupERel env n))) - (freeVars (exp', dummyLoc)))) - </obind/> - (fn args => cacheWrap (env, (exp', dummyLoc), typ, args, state)) - fun cache (effs : IS.set) ((env, exp as (exp', loc)), state) = let fun wrapBindN (f : exp list -> exp') (args : (MonoEnv.env * exp) list) = @@ -896,13 +899,13 @@ in (Impure (exp', loc), state) end - | _ => if effectful effs env exp - then (Impure exp, state) - else (Cachable (fn state => + | _ => (if effectful effs env exp + then Impure exp + else Cachable (fn state => case cachePure (env, exp', state) of - NONE => ((exp', loc), state) - | SOME (exp', state) => ((exp', loc), state)), - state) + NONE => ((exp', loc), state) + | SOME (exp', state) => ((exp', loc), state)), + state) end fun addCaching file = @@ -934,11 +937,7 @@ 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 + List.tabulate (numArgs, (fn n => IM.find (eqs, n))) (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here represents unknown, which means a wider invalidation. *)