changeset 2213:365727ff68f4

Complete overhaul: cache queries based on immediate query result, not eventual HTML output.
author Ziv Scully <ziv@mit.edu>
date Tue, 14 Oct 2014 18:05:09 -0400
parents 388ba4dc7c96
children edd634b889d0
files caching-tests/test.db caching-tests/test.sql caching-tests/test.ur caching-tests/test.urp caching-tests/test.urs src/cjr_print.sml src/compiler.sig src/compiler.sml src/monoize.sig src/monoize.sml src/multimap_fn.sml src/settings.sig src/settings.sml src/sources src/sql.sig src/sql.sml src/sqlcache.sml
diffstat 17 files changed, 413 insertions(+), 85 deletions(-) [+]
line wrap: on
line diff
Binary file caching-tests/test.db has changed
--- a/caching-tests/test.sql	Mon Sep 15 20:01:16 2014 -0400
+++ b/caching-tests/test.sql	Tue Oct 14 18:05:09 2014 -0400
@@ -8,4 +8,9 @@
    
   );
   
-  
\ No newline at end of file
+  CREATE TABLE uw_Test_tab(uw_id integer NOT NULL, uw_val integer NOT NULL,
+   PRIMARY KEY (uw_id)
+    
+   );
+   
+   
\ No newline at end of file
--- a/caching-tests/test.ur	Mon Sep 15 20:01:16 2014 -0400
+++ b/caching-tests/test.ur	Tue Oct 14 18:05:09 2014 -0400
@@ -1,52 +1,74 @@
 table foo01 : {Id : int, Bar : string} PRIMARY KEY Id
 table foo10 : {Id : int, Bar : string} PRIMARY KEY Id
+table tab : {Id : int, Val : int} PRIMARY KEY Id
 
-fun flush01 () : transaction page =
+fun cache01 () =
+    res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42);
+    return <xml><body>
+      Reading 1.
+      {case res of
+           None => <xml>?</xml>
+         | Some row => <xml>{[row.Foo01.Bar]}</xml>}
+    </body></xml>
+
+fun cache10 () =
+    res <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42);
+    return <xml><body>
+      Reading 2.
+      {case res of
+           None => <xml>?</xml>
+         | Some row => <xml>{[row.Foo10.Bar]}</xml>}
+    </body></xml>
+
+fun cache11 () =
+    res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42);
+    bla <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42);
+    return <xml><body>
+      Reading 1 and 2.
+      {case res of
+           None => <xml>?</xml>
+         | Some row => <xml>{[row.Foo01.Bar]}</xml>}
+      {case bla of
+           None => <xml>?</xml>
+         | Some row => <xml>{[row.Foo10.Bar]}</xml>}
+    </body></xml>
+
+fun flush01 () =
     dml (UPDATE foo01 SET Bar = "baz01" WHERE Id = 42);
     return <xml><body>
       Flushed 1!
     </body></xml>
 
-fun flush10 () : transaction page =
+fun flush10 () =
     dml (UPDATE foo10 SET Bar = "baz10" WHERE Id = 42);
     return <xml><body>
       Flushed 2!
     </body></xml>
 
-fun flush11 () : transaction page =
+fun flush11 () =
     dml (UPDATE foo01 SET Bar = "baz11" WHERE Id = 42);
     dml (UPDATE foo10 SET Bar = "baz11" WHERE Id = 42);
     return <xml><body>
       Flushed 1 and 2!
     </body></xml>
 
-fun cache01 () : transaction page =
-    res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42);
+fun cache id =
+    res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]});
     return <xml><body>
-      Reading 1.
+      Reading {[id]}.
       {case res of
-           None => <xml></xml>
-         | Some row => <xml>{[row.Foo01.Bar]}</xml>}
+           None => <xml>?</xml>
+         | Some row => <xml>{[row.Tab.Val]}</xml>}
     </body></xml>
 
-fun cache10 () : transaction page =
-    res <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42);
+fun flush id =
+    res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]});
+    dml (case res of
+             None => (INSERT INTO tab (Id, Val) VALUES ({[id]}, 0))
+           | Some row => (UPDATE tab SET Val = {[row.Tab.Val + 1]} WHERE Id = {[id]}));
     return <xml><body>
-      Reading 2.
+      (* Flushed {[id]}! *)
       {case res of
-           None => <xml></xml>
-         | Some row => <xml>{[row.Foo10.Bar]}</xml>}
+           None => <xml>Initialized {[id]}!</xml>
+         | Some row => <xml>Incremented {[id]}!</xml>}
     </body></xml>
-
-fun cache11 () : transaction page =
-    res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42);
-    bla <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42);
-    return <xml><body>
-      Reading 1 and 2.
-      {case res of
-           None => <xml></xml>
-         | Some row => <xml>{[row.Foo01.Bar]}</xml>}
-      {case bla of
-           None => <xml></xml>
-         | Some row => <xml>{[row.Foo10.Bar]}</xml>}
-    </body></xml>
--- a/caching-tests/test.urp	Mon Sep 15 20:01:16 2014 -0400
+++ b/caching-tests/test.urp	Tue Oct 14 18:05:09 2014 -0400
@@ -3,5 +3,6 @@
 safeGet Test/flush01
 safeGet Test/flush10
 safeGet Test/flush11
+safeGet Test/flush
 
 test
--- a/caching-tests/test.urs	Mon Sep 15 20:01:16 2014 -0400
+++ b/caching-tests/test.urs	Tue Oct 14 18:05:09 2014 -0400
@@ -4,3 +4,5 @@
 val flush01 : unit -> transaction page
 val flush10 : unit -> transaction page
 val flush11 : unit -> transaction page
+val cache : int -> transaction page
+val flush : int -> transaction page
--- a/src/cjr_print.sml	Mon Sep 15 20:01:16 2014 -0400
+++ b/src/cjr_print.sml	Tue Oct 14 18:05:09 2014 -0400
@@ -3395,49 +3395,77 @@
 
              (* For sqlcache. *)
              box (List.map
-                      (fn index =>
+                      (fn {index, params} =>
                           let val i = Int.toString index
+                              fun paramRepeat itemi sep =
+                                  let
+                                      val rec f =
+                                       fn 0 => itemi (Int.toString 0)
+                                        | n => f (n-1) ^ itemi (Int.toString n)
+                                  in
+                                      f (params - 1)
+                                  end
+                              val args = paramRepeat (fn p => "uw_Basis_string p" ^ p) ", "
+                              val decls = paramRepeat (fn p => "uw_Basis_string param" ^ i ^ "_" ^ p ^ " = NULL;") "\n"
+                              val sets = paramRepeat (fn p => "param" ^ i ^ "_" ^ p
+                                                             ^ " = strdup(p" ^ p ^ ");") "\n"
+                              val frees = paramRepeat (fn p => "free(param" ^ i ^ "_" ^ p ^ ");") "\n"
+                              val eqs = paramRepeat (fn p => "strcmp(param" ^ i ^ "_" ^ p
+                                                             ^ ", p" ^ p ^ ")") " || "
                           in box [string "static char *cache",
                                   string i,
                                   string " = NULL;",
                                   newline,
-                                  string "static uw_Basis_bool uw_Cache_check",
+                                  string decls,
+                                  newline,
+                                  string "static uw_Basis_string uw_Sqlcache_check",
                                   string i,
-                                  string "(uw_context ctx) { puts(\"SQLCACHE: checked ",
+                                  string "(uw_context ctx, ",
+                                  string args,
+                                  string ") {\n puts(\"SQLCACHE: checked ",
                                   string i,
-                                  string ".\"); if (cache",
+                                  string ".\");\n if (cache",
                                   string i,
-                                  string " == NULL) { uw_recordingStart(ctx); return uw_Basis_False; } else { uw_write(ctx, cache",
+                                  (* ASK: is returning the pointer okay? Should we duplicate? *)
+                                  string " == NULL || ",
+                                  string eqs,
+                                  string ") {\n puts(\"miss D:\"); puts(p0);\n return NULL;\n } else {\n puts(\"hit :D\");\n return cache",
                                   string i,
-                                  string "); puts(\"SQLCACHE: used ",
+                                  string ";\n } };",
+                                  newline,
+                                  string "static uw_unit uw_Sqlcache_store",
                                   string i,
-                                  string ".\"); return uw_Basis_True; } };",
+                                  string "(uw_context ctx, uw_Basis_string s, ",
+                                  string args,
+                                  string ") {\n free(cache",
+                                  string i,
+                                  string ");",
                                   newline,
-                                  string "static uw_unit uw_Cache_store",
+                                  string frees,
+                                  newline,
+                                  string "cache",
                                   string i,
-                                  string "(uw_context ctx) { cache",
+                                  string " = strdup(s);",
+                                  newline,
+                                  string sets,
+                                  newline,
+                                  string "puts(\"SQLCACHE: stored ",
                                   string i,
-                                  string " = uw_recordingRead(ctx); puts(\"SQLCACHE: stored ",
+                                  string ".\"); puts(p0);\n return uw_unit_v;\n };",
+                                  newline,
+                                  string "static uw_unit uw_Sqlcache_flush",
                                   string i,
-                                  string ".\"); return uw_unit_v; };",
-                                  newline,
-                                  string "static uw_unit uw_Cache_flush",
+                                  string "(uw_context ctx) {\n free(cache",
                                   string i,
-                                  string "(uw_context ctx) { free(cache",
+                                  string ");\n cache",
                                   string i,
-                                  string "); cache",
+                                  string " = NULL;\n puts(\"SQLCACHE: flushed ",
                                   string i,
-                                  string " = NULL; puts(\"SQLCACHE: flushed ",
-                                  string i,
-                                  string ".\"); return uw_unit_v; };",
-                                  newline,
-                                  string "static uw_unit uw_Cache_ready",
-                                  string i,
-                                  string "(uw_context ctx) { return uw_unit_v; };",
+                                  string ".\");\n return uw_unit_v;\n };",
                                   newline,
                                   newline]
                           end)
-                      (!Sqlcache.ffiIndices)),
+                      (Sqlcache.getFfiInfo ())),
              newline,
 
              p_list_sep newline (fn x => x) pds,
--- a/src/compiler.sig	Mon Sep 15 20:01:16 2014 -0400
+++ b/src/compiler.sig	Tue Oct 14 18:05:09 2014 -0400
@@ -199,7 +199,6 @@
     val enableBoot : unit -> unit
 
     val doIflow : bool ref
-    val doSqlcache : bool ref
 
     val addPath : string * string -> unit
     val addModuleRoot : string * string -> unit
--- a/src/compiler.sml	Mon Sep 15 20:01:16 2014 -0400
+++ b/src/compiler.sml	Tue Oct 14 18:05:09 2014 -0400
@@ -83,7 +83,6 @@
 val debug = ref false
 val dumpSource = ref false
 val doIflow = ref false
-val doSqlcache = ref false
 
 val doDumpSource = ref (fn () => ())
 
@@ -1457,7 +1456,10 @@
 val toSigcheck = transform sigcheck "sigcheck" o toSidecheck
 
 val sqlcache = {
-    func = (fn file => (if !doSqlcache then Sqlcache.go file else file)),
+    func = (fn file =>
+               if Settings.getSqlcache ()
+               then let val file = MonoInline.inlineFull file in Sqlcache.go file end
+               else file),
     print = MonoPrint.p_file MonoEnv.empty
 }
 
--- a/src/monoize.sig	Mon Sep 15 20:01:16 2014 -0400
+++ b/src/monoize.sig	Tue Oct 14 18:05:09 2014 -0400
@@ -16,7 +16,7 @@
  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
--- a/src/monoize.sml	Mon Sep 15 20:01:16 2014 -0400
+++ b/src/monoize.sml	Tue Oct 14 18:05:09 2014 -0400
@@ -1957,20 +1957,26 @@
                                                           (L'.TFun (un, state), loc)),
                                                  loc)), loc)
 
-                             val body' = (L'.EApp (
+                             val body'' = (L'.EApp (
                                           (L'.EApp (
                                            (L'.EApp ((L'.ERel 4, loc),
                                                      (L'.ERel 1, loc)), loc),
                                            (L'.ERel 0, loc)), loc),
                                           (L'.ERecord [], loc)), loc)
-
-                             val body = (L'.EQuery {exps = exps,
-                                                    tables = tables,
-                                                    state = state,
-                                                    query = (L'.ERel 3, loc),
-                                                    body = body',
-                                                    initial = (L'.ERel 1, loc)},
-                                         loc)
+                             val body' = (L'.EQuery {exps = exps,
+                                                      tables = tables,
+                                                      state = state,
+                                                      query = (L'.ERel 3, loc),
+                                                      body = body'',
+                                                      initial = (L'.ERel 1, loc)},
+                                           loc)
+                             val (body, fm) = if Settings.getSqlcache () then
+                                                  let
+                                                      val (urlifiedRel0, fm) = urlifyExp env fm ((L'.ERel 0, loc), state)
+                                                  in
+                                                      (Sqlcache.instrumentQuery (body', urlifiedRel0), fm)
+                                                  end
+                                              else (body', fm)
                          in
                              ((L'.EAbs ("q", s, (L'.TFun (ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc)), loc),
                                         (L'.EAbs ("f", ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc),
--- a/src/multimap_fn.sml	Mon Sep 15 20:01:16 2014 -0400
+++ b/src/multimap_fn.sml	Tue Oct 14 18:05:09 2014 -0400
@@ -1,14 +1,16 @@
 functor MultimapFn (structure KeyMap : ORD_MAP structure ValSet : ORD_SET) = struct
     type key = KeyMap.Key.ord_key
     type item = ValSet.item
-    type items = ValSet.set
+    type itemSet = ValSet.set
     type multimap = ValSet.set KeyMap.map
-    fun inserts (kToVs : multimap, k : key, vs : items) : multimap =
+    val empty : multimap = KeyMap.empty
+    fun insertSet (kToVs : multimap, k : key, vs : itemSet) : multimap =
         KeyMap.unionWith ValSet.union (kToVs, KeyMap.singleton (k, vs))
     fun insert (kToVs : multimap, k : key, v : item) : multimap =
-        inserts (kToVs, k, ValSet.singleton v)
-    fun find (kToVs : multimap, k : key) =
+        insertSet (kToVs, k, ValSet.singleton v)
+    fun findSet (kToVs : multimap, k : key) =
         case KeyMap.find (kToVs, k) of
             SOME vs => vs
           | NONE => ValSet.empty
+    val findList : multimap * key -> item list = ValSet.listItems o findSet
 end
--- a/src/settings.sig	Mon Sep 15 20:01:16 2014 -0400
+++ b/src/settings.sig	Tue Oct 14 18:05:09 2014 -0400
@@ -279,6 +279,9 @@
     val setLessSafeFfi : bool -> unit
     val getLessSafeFfi : unit -> bool
 
+    val setSqlcache : bool -> unit
+    val getSqlcache : unit -> bool
+
     val setFilePath : string -> unit
     (* Sets the directory where we look for files being added below. *)
 
--- a/src/settings.sml	Mon Sep 15 20:01:16 2014 -0400
+++ b/src/settings.sml	Tue Oct 14 18:05:09 2014 -0400
@@ -744,6 +744,10 @@
 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
--- a/src/sources	Mon Sep 15 20:01:16 2014 -0400
+++ b/src/sources	Tue Oct 14 18:05:09 2014 -0400
@@ -212,6 +212,8 @@
 $(SRC)/sqlcache.sig
 $(SRC)/sqlcache.sml
 
+$(SRC)/mono_inline.sml
+
 $(SRC)/cjr.sml
 
 $(SRC)/postgres.sig
--- a/src/sql.sig	Mon Sep 15 20:01:16 2014 -0400
+++ b/src/sql.sig	Tue Oct 14 18:05:09 2014 -0400
@@ -2,6 +2,8 @@
 
 val debug : bool ref
 
+val sqlcacheMode : bool ref
+
 type lvar = int
 
 datatype func =
--- a/src/sql.sml	Mon Sep 15 20:01:16 2014 -0400
+++ b/src/sql.sml	Tue Oct 14 18:05:09 2014 -0400
@@ -270,6 +270,22 @@
 
       | _ => NONE
 
+fun sqlifySqlcache chs =
+    case chs of
+        (* Match entire FFI application, not just its argument. *)
+        Exp (e' as EFfiApp ("Basis", f, [(_, _)]), _) :: chs =>
+        if String.isPrefix "sqlify" f then
+            SOME ((e', ErrorMsg.dummySpan), chs)
+        else
+            NONE
+      | Exp (ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _),
+                         (EPrim (Prim.String (Prim.Normal, "TRUE")), _)),
+                        ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _),
+                         (EPrim (Prim.String (Prim.Normal, "FALSE")), _))], _), _) :: chs =>
+        SOME (e, chs)
+
+      | _ => NONE
+
 fun constK s = wrap (const s) (fn () => s)
 
 val funcName = altL [constK "COUNT",
@@ -281,6 +297,8 @@
 val unmodeled = altL [const "COUNT(*)",
                       const "CURRENT_TIMESTAMP"]
 
+val sqlcacheMode = ref false;
+
 fun sqexp chs =
     log "sqexp"
     (altL [wrap prim SqConst,
@@ -292,7 +310,7 @@
            wrap known SqKnown,
            wrap func SqFunc,
            wrap unmodeled (fn () => Unmodeled),
-           wrap sqlify Inj,
+           wrap (if !sqlcacheMode then sqlifySqlcache else sqlify) Inj,
            wrap (follow (const "COALESCE(") (follow sqexp (follow (const ",")
                                                                   (follow (keep (fn ch => ch <> #")")) (const ")")))))
                 (fn ((), (e, _)) => e),
--- a/src/sqlcache.sml	Mon Sep 15 20:01:16 2014 -0400
+++ b/src/sqlcache.sml	Tue Oct 14 18:05:09 2014 -0400
@@ -1,21 +1,247 @@
-structure Sqlcache :> SQLCACHE = struct
+structure Sqlcache (* :> SQLCACHE *) = struct
 
 open Sql
 open Mono
 
 structure IS = IntBinarySet
 structure IM = IntBinaryMap
-structure StringKey = struct type ord_key = string val compare = String.compare end
-structure SS = BinarySetFn (StringKey)
-structure SM = BinaryMapFn (StringKey)
-structure SIMM = MultimapFn (structure KeyMap = SM structure ValSet = IS)
+structure SK = struct type ord_key = string val compare = String.compare end
+structure SS = BinarySetFn(SK)
+structure SM = BinaryMapFn(SK)
+structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS)
 
-val ffiIndices : int list ref = ref []
+(* Filled in by cacheWrap during Sqlcache. *)
+val ffiInfo : {index : int, params : int} list ref = ref []
 
-(* Expression construction utilities. *)
+fun getFfiInfo () = !ffiInfo
+
+(* Program analysis. *)
+
+val useInjIfPossible =
+ fn SqConst prim => Inj (EPrim (Prim.String (Prim.Normal, Prim.toString prim)), ErrorMsg.dummySpan)
+  | sqexp => sqexp
+
+fun equalities (canonicalTable : string -> string) :
+    sqexp -> ((string * string) * Mono.exp) list option =
+    let
+        val rec eqs =
+         fn Binop (Exps f, e1, e2) =>
+            (* TODO: use a custom datatype in Exps instead of a function. *)
+            (case f (Var 1, Var 2) of
+                 Reln (Eq, [Var 1, Var 2]) =>
+                 let
+                     val (e1', e2') = (useInjIfPossible e1, useInjIfPossible e2)
+                 in
+                     case (e1', e2') of
+                         (Field (t, f), Inj i) => SOME [((canonicalTable t, f), i)]
+                       | (Inj i, Field (t, f)) => SOME [((canonicalTable t, f), i)]
+                       | _ => NONE
+                 end
+               | _ => NONE)
+          | Binop (Props f, e1, e2) =>
+            (* TODO: use a custom datatype in Props instead of a function. *)
+            (case f (True, False) of
+                 And (True, False) =>
+                 (case (eqs e1, eqs e2) of
+                      (SOME eqs1, SOME eqs2) => SOME (eqs1 @ eqs2)
+                    | _ => NONE)
+               | _ => NONE)
+          | _ => NONE
+    in
+        eqs
+    end
+
+val equalitiesQuery =
+ fn Query1 {From = tablePairs, Where = SOME exp, ...} =>
+    equalities
+        (* If we have [SELECT ... FROM T AS T' ...], use T, not T'. *)
+        (fn t =>
+            case List.find (fn (_, tAs) => t = tAs) tablePairs of
+                NONE => t
+              | SOME (tOrig, _) => tOrig)
+        exp
+  | Query1 {Where = NONE, ...} => SOME []
+  | _ => NONE
+
+val equalitiesDml =
+ fn Insert (tab, eqs) => SOME (List.mapPartial
+                                   (fn (name, sqexp) =>
+                                       case useInjIfPossible sqexp of
+                                           Inj e => SOME ((tab, name), e)
+                                         | _ => NONE)
+                                   eqs)
+  | Delete (tab, exp) => equalities (fn _ => tab) exp
+  (* TODO: examine the updated values and not just the way they're filtered. *)
+  (* For example, UPDATE foo SET Id = 9001 WHERE Id = 42 should update both the
+     Id = 42 and Id = 9001 cache entries. Could also think of it as doing a
+     Delete immediately followed by an Insert. *)
+  | Update (tab, _, exp) => equalities (fn _ => tab) exp
+
+val rec tablesQuery =
+ fn Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs)
+  | Union (q1, q2) => SS.union (tablesQuery q1, tablesQuery q2)
+
+val tableDml =
+ fn Insert (tab, _) => tab
+  | Delete (tab, _) => tab
+  | Update (tab, _, _) => tab
+
+
+(* Program instrumentation. *)
+
+val stringTyp = (TFfi ("Basis", "string"), ErrorMsg.dummySpan)
+
+val sequence =
+ fn (exp :: exps) =>
+    let
+        val loc = ErrorMsg.dummySpan
+    in
+        List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps
+    end
+  | _ => raise Match
+
+fun ffiAppCache' (func, index, args) : Mono.exp' =
+    EFfiApp ("Sqlcache", func ^ Int.toString index, args)
+
+fun ffiAppCache (func, index, args) : Mono. exp =
+    (ffiAppCache' (func, index, args), ErrorMsg.dummySpan)
+
+val varPrefix = "queryResult"
+
+fun indexOfName varName =
+    if String.isPrefix varPrefix varName
+    then Int.fromString (String.extract (varName, String.size varPrefix, NONE))
+    else NONE
+
+val incRels = MonoUtil.Exp.map {typ = fn x => x, exp = fn ERel n => ERel (n + 1) | x => x}
+
+(* Filled in by instrumentQuery during Monoize, used during Sqlcache. *)
+val urlifiedRel0s : Mono.exp IM.map ref = ref IM.empty
+
+(* Used by Monoize. *)
+val instrumentQuery =
+    let
+        val nextQuery = ref 0
+        fun iq (query, urlifiedRel0) =
+            case query of
+                (EQuery {state = typ, ...}, loc) =>
+                let
+                    val i = !nextQuery before nextQuery := !nextQuery + 1
+                in
+                    urlifiedRel0s := IM.insert (!urlifiedRel0s, i, urlifiedRel0);
+                    (* ASK: name variables properly? *)
+                    (ELet (varPrefix ^ Int.toString i, typ, query,
+                           (* Uses a dummy FFI call to keep the urlified expression around, which
+                              in turn keeps the declarations required for urlification safe from
+                              MonoShake. The dummy call is removed during Sqlcache. *)
+                           (* ASK: is there a better way? *)
+                           (ESeq ((EFfiApp ("Sqlcache", "dummy", [(urlifiedRel0, stringTyp)]), loc),
+                                  (ERel 0, loc)),
+                            loc)),
+                     loc)
+                end
+              | _ => raise Match
+    in
+        iq
+    end
+
+val gunk : ((string * string) * Mono.exp) list list ref = ref [[]]
+
+fun cacheWrap (query, i, urlifiedRel0, eqs) =
+    case query of
+        (EQuery {state = typ, ...}, _) =>
+        let
+            val loc = ErrorMsg.dummySpan
+            (* TODO: deal with effectful injected expressions. *)
+            val args = (ffiInfo := {index = i, params = length eqs} :: !ffiInfo;
+                        map (fn (_, e) => (e, stringTyp)) eqs) before gunk := eqs :: !gunk
+            val argsInc = map (fn (e, t) => (incRels e, t)) args
+        in
+            (ECase (ffiAppCache ("check", i, args),
+                    [((PNone stringTyp, loc),
+                      (ELet ("q", typ, query,
+                             (ESeq (ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argsInc),
+                                    (ERel 0, loc)),
+                              loc)),
+                       loc)),
+                     ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc),
+                      (* ASK: what does this bool do? *)
+                      (EUnurlify ((ERel 0, loc), typ, false), loc))],
+                    {disc = stringTyp, result = typ}),
+             loc)
+        end
+      | _ => raise Match
+
+fun fileMapfold doExp file start =
+    case MonoUtil.File.mapfold {typ = Search.return2,
+                                exp = fn x => (fn s => Search.Continue (doExp x s)),
+                                decl = Search.return2} file start of
+        Search.Continue x => x
+      | Search.Return _ => raise Match
+
+fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ())
+
+val addChecking =
+    let
+        fun doExp queryInfo =
+         fn e' as ELet (v, t, queryExp as (EQuery {query = queryText, ...}, _), body) =>
+            let
+                fun bind x f = Option.mapPartial f x
+                val attempt =
+                    (* Ziv misses Haskell's do notation.... *)
+                    bind (parse query queryText) (fn queryParsed =>
+                    (Print.preface ("gunk> ", (MonoPrint.p_exp MonoEnv.empty queryExp));
+                    bind (indexOfName v) (fn i =>
+                    bind (equalitiesQuery queryParsed) (fn eqs =>
+                    bind (IM.find (!urlifiedRel0s, i)) (fn urlifiedRel0 =>
+                    SOME (ELet (v, t, cacheWrap (queryExp, i, urlifiedRel0, eqs), body),
+                          SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, i))
+                                   queryInfo
+                                   (tablesQuery queryParsed)))))))
+            in
+                case attempt of
+                    SOME pair => pair
+                  | NONE => (e', queryInfo)
+            end
+          | ESeq ((EFfiApp ("Sqlcache", "dummy", _), _), (e', _)) => (e', queryInfo)
+          | e' => (e', queryInfo)
+    in
+        fn file => fileMapfold (fn exp => fn state => doExp state exp) file SIMM.empty
+    end
+
+fun addFlushing (file, queryInfo) =
+    let
+        val allIndices : int list = SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] queryInfo
+        fun flushes indices = map (fn i => ffiAppCache' ("flush", i, [])) indices
+        val doExp =
+         fn dmlExp as EDml (dmlText, _) =>
+            let
+                val indices =
+                    case parse dml dmlText of
+                        SOME dmlParsed => SIMM.findList (queryInfo, tableDml dmlParsed)
+                      | NONE => allIndices
+            in
+                sequence (flushes indices @ [dmlExp])
+            end
+          | e' => e'
+    in
+        fileMap doExp file
+    end
+
+fun go file =
+    let
+        val () = Sql.sqlcacheMode := true
+    in
+        addFlushing (addChecking file) before Sql.sqlcacheMode := false
+    end
+
+
+(* BEGIN OLD
 
 fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc)
 fun intTyp loc = (TFfi ("Basis", "int"), loc)
+fun stringExp (s, loc) = (EPrim (Prim.String (Prim.Normal, s)), loc)
+
 fun boolPat (b, loc) = (PCon (Enum,
                               PConFfi {mod = "Basis", datatyp = "bool", arg = NONE,
                                        con = if b then "True" else "False"},
@@ -23,11 +249,13 @@
                         loc)
 fun boolTyp loc = (TFfi ("Basis", "int"), loc)
 
-fun ffiAppExp (module, func, index, loc) =
-    (EFfiApp (module, func ^ Int.toString index, []), loc)
+fun ffiAppExp (module, func, index, args, loc) =
+    (EFfiApp (module, func ^ Int.toString index, args), loc)
 
-fun sequence ((exp :: exps), loc) =
+val sequence =
+ fn ((exp :: exps), loc) =>
     List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc)) exp exps
+  | _ => raise Match
 
 fun antiguardUnit (cond, exp, loc) =
     (ECase (cond,
@@ -41,11 +269,10 @@
         EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc)
       | _ => f exp
 
-(* Program analysis and augmentation. *)
 
 val rec tablesRead =
- fn Query1 {From=tablePairs, ...} => SS.fromList (map #1 tablePairs)
-  | Union (q1,q2) => SS.union (tablesRead q1, tablesRead q2)
+ fn Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs)
+  | Union (q1, q2) => SS.union (tablesRead q1, tablesRead q2)
 
 val tableWritten =
  fn Insert (tab, _) => tab
@@ -57,7 +284,7 @@
         val nothing = {read = SS.empty, written = SS.empty}
     in
         case exp' of
-            EQuery {query=e, ...} =>
+            EQuery {query = e, ...} =>
             (case parse query e of
                  SOME q => {read = tablesRead q, written = SS.empty}
                | NONE => nothing)
@@ -71,8 +298,11 @@
 val tablesInExp =
     let
         fun addTables (exp', {read, written}) =
-            let val {read = r, written = w} = tablesInExp' exp'
-            in {read = SS.union (r, read), written = SS.union (w, written)} end
+            let
+                val {read = r, written = w} = tablesInExp' exp'
+            in
+                {read = SS.union (r, read), written = SS.union (w, written)}
+            end
     in
         MonoUtil.Exp.fold {typ = #2, exp = addTables}
                           {read = SS.empty, written = SS.empty}
@@ -150,7 +380,7 @@
     in
         case MonoUtil.File.mapfold {typ = nada, exp = nada, decl = doDecl} file init of
             Search.Continue x => x
-          | _ => (file, init) (* Should never happen. *)
+          | _ => raise Match (* Should never happen. *)
     end
 
 fun fileMapSelected f = #1 o fileFoldMapiSelected (fn (_, x, _) => (f x, ())) ()
@@ -178,4 +408,6 @@
         addCacheFlushing (fileWithChecks, tablesToIndices, writers)
     end
 
+END OLD *)
+
 end