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. *)