Factor out cache implementation from Sqlcache.

3 files changed, 19 insertions, 141 deletions

diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 1b1d656d..12ad309a 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -3404,111 +3404,7 @@ fun p_file env (ds, ps) =
              newline,
 
              (* For sqlcache. *)
-             box (List.map
-                      (fn {index, params} =>
-                          let val i = Int.toString index
-                              fun paramRepeat itemi sep =
-                                  let
-                                      fun f n =
-                                          if n < 0 then ""
-                                          else if n = 0 then itemi (Int.toString 0)
-                                          else f (n-1) ^ sep ^ itemi (Int.toString n)
-                                  in
-                                      f (params - 1)
-                                  end
-                              fun paramRepeatInit itemi sep =
-                                  if params = 0 then "" else sep ^ paramRepeat itemi sep
-                              val args = paramRepeatInit (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 = paramRepeatInit (fn p => "strcmp(param" ^ i ^ "_" ^ p
-                                                                 ^ ", p" ^ p ^ ")")
-                                                        " || "
-                              (* Using [!=] instead of [==] to mimic [strcmp]. *)
-                              val eqsNull = paramRepeatInit (fn p => "(p" ^ p ^ " == NULL || "
-                                                                     ^ "!strcmp(param" ^ i ^ "_"
-                                                                     ^ p ^ ", p" ^ p ^ "))")
-                                                            " && "
-                          in box [string "static char *cacheQuery",
-                                  string i,
-                                  string " = NULL;",
-                                  newline,
-                                  string "static char *cacheWrite",
-                                  string i,
-                                  string " = NULL;",
-                                  newline,
-                                  string decls,
-                                  newline,
-                                  string "static uw_Basis_string uw_Sqlcache_check",
-                                  string i,
-                                  string "(uw_context ctx",
-                                  string args,
-                                  string ") {\n if (cacheQuery",
-                                  string i,
-                                  (* ASK: is returning the pointer okay? Should we duplicate? *)
-                                  string " == NULL",
-                                  string eqs,
-                                  string ") {\n puts(\"SQLCACHE: miss ",
-                                  string i,
-                                  string ".\");\n uw_recordingStart(ctx);\n return NULL;\n } else {\n puts(\"SQLCACHE: hit ",
-                                  string i,
-                                  string ".\");\n uw_write(ctx, cacheWrite",
-                                  string i,
-                                  string ");\n return cacheQuery",
-                                  string i,
-                                  string ";\n } };",
-                                  newline,
-                                  string "static uw_unit uw_Sqlcache_store",
-                                  string i,
-                                  string "(uw_context ctx, uw_Basis_string s",
-                                  string args,
-                                  string ") {\n free(cacheQuery",
-                                  string i,
-                                  string "); free(cacheWrite",
-                                  string i,
-                                  string ");",
-                                  newline,
-                                  string frees,
-                                  newline,
-                                  string "cacheQuery",
-                                  string i,
-                                  string " = strdup(s); cacheWrite",
-                                  string i,
-                                  string " = uw_recordingRead(ctx);",
-                                  newline,
-                                  string sets,
-                                  newline,
-                                  string "puts(\"SQLCACHE: store ",
-                                  string i,
-                                  string ".\");\n return uw_unit_v;\n };",
-                                  newline,
-                                  string "static uw_unit uw_Sqlcache_flush",
-                                  string i,
-                                  string "(uw_context ctx",
-                                  string args,
-                                  string ") {\n if (cacheQuery",
-                                  string i,
-                                  string " != NULL",
-                                  string eqsNull,
-                                  string ") {\n free(cacheQuery",
-                                  string i,
-                                  string ");\n cacheQuery",
-                                  string i,
-                                  string " = NULL;\n puts(\"SQLCACHE: flush ",
-                                  string i,
-                                  string ".\");}\n else { puts(\"SQLCACHE: keep ",
-                                  string i,
-                                  string ".\"); } return uw_unit_v;\n };",
-                                  newline,
-                                  newline]
-                          end)
-                      (Sqlcache.getFfiInfo ())),
+             box (List.map ToyCache.setupQuery (Sqlcache.getFfiInfo ())),
              newline,
 
              p_list_sep newline (fn x => x) pds,
diff --git a/src/sources b/src/sources
index 33c01f94..05897cd4 100644
--- a/src/sources
+++ b/src/sources
@@ -175,6 +175,8 @@ $(SRC)/union_find_fn.sml
 
 $(SRC)/multimap_fn.sml
 
+$(SRC)/toy_cache.sml
+
 $(SRC)/sqlcache.sig
 $(SRC)/sqlcache.sml
 
diff --git a/src/sqlcache.sml b/src/sqlcache.sml
index f60555e8..931c6737 100644
--- a/src/sqlcache.sml
+++ b/src/sqlcache.sml
@@ -43,7 +43,7 @@ val ffiEffectful =
 (* Effect analysis. *)
 
 (* Makes an exception for [EWrite] (which is recorded when caching). *)
-fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : Mono.exp -> bool =
+fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : exp -> bool =
     (* If result is true, expression is definitely effectful. If result is
        false, then expression is definitely not effectful if effs is fully
        populated. The intended pattern is to use this a number of times equal
@@ -183,6 +183,7 @@ fun mapFormula mf =
   | Negate f => Negate (mapFormula mf f)
   | Combo (n, fs) => Combo (n, map (mapFormula mf) fs)
 
+
 (* SQL analysis. *)
 
 val rec chooseTwos : 'a list -> ('a * 'a) list =
@@ -365,33 +366,21 @@ val tableDml =
 
 (* Program instrumentation. *)
 
-fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), ErrorMsg.dummySpan)
+val dummyLoc = ErrorMsg.dummySpan
+
+fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), dummyLoc)
 
-val stringTyp = (TFfi ("Basis", "string"), ErrorMsg.dummySpan)
+val stringTyp = (TFfi ("Basis", "string"), dummyLoc)
 
 val sequence =
  fn (exp :: exps) =>
     let
-        val loc = ErrorMsg.dummySpan
+        val loc = dummyLoc
     in
         List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps
     end
   | _ => raise Match
 
-(* TODO: factor out. *)
-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
-
 (* Always increments negative indices because that's what we need later. *)
 fun incRelsBound bound inc =
     MonoUtil.Exp.mapB
@@ -407,13 +396,12 @@ val incRels = incRelsBound 0
 fun cacheWrap (query, i, urlifiedRel0, resultTyp, args) =
     let
         val () = ffiInfo := {index = i, params = length args} :: !ffiInfo
-        val loc = ErrorMsg.dummySpan
+        val loc = dummyLoc
         (* We ensure before this step that all arguments aren't effectful.
            by turning them into local variables as needed. *)
-        val argTyps = map (fn e => (e, stringTyp)) args
-        val argTypsInc = map (fn (e, typ) => (incRels 1 e, typ)) argTyps
-        val check = ffiAppCache ("check", i, argTyps)
-        val store = ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argTypsInc)
+        val argsInc = map (incRels 1) args
+        val check = (ToyCache.check (i, args), dummyLoc)
+        val store = (ToyCache.store (i, argsInc, urlifiedRel0), dummyLoc)
         val rel0 = (ERel 0, loc)
     in
         ECase (check,
@@ -436,7 +424,7 @@ fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ()
 
 fun factorOutNontrivial text =
     let
-        val loc = ErrorMsg.dummySpan
+        val loc = dummyLoc
         fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
         val chunks = Sql.chunkify text
         val (newText, newVariables) =
@@ -486,10 +474,10 @@ fun addChecking file =
                                                 body = body,
                                                 tables = tables,
                                                 exps = exps},
-                                        ErrorMsg.dummySpan)
+                                        dummyLoc)
                 val (EQuery {query = queryText, ...}, _) = queryExp
                 val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText))
-                val args = List.tabulate (numArgs, fn n => (ERel n, ErrorMsg.dummySpan))
+                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
                 (* DEBUG: set first boolean argument to true to turn on printing. *)
@@ -516,7 +504,7 @@ fun addChecking file =
 
 fun invalidations ((query, numArgs), dml) =
     let
-        val loc = ErrorMsg.dummySpan
+        val loc = dummyLoc
         val optionAtomExpToExp =
          fn NONE => (ENone stringTyp, loc)
           | SOME e => (ESome (stringTyp,
@@ -556,16 +544,8 @@ fun invalidations ((query, numArgs), dml) =
 
 fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) =
     let
-        (* ASK: does this type actually matter? It was wrong before, but things
-           still seemed to work. *)
-        val optionStringTyp = (TOption stringTyp, ErrorMsg.dummySpan)
         val flushes = List.concat o
-                      map (fn (i, argss) =>
-                              map (fn args =>
-                                      ffiAppCache' ("flush", i,
-                                                    map (fn arg => (arg, optionStringTyp))
-                                                        args))
-                                  argss)
+                      map (fn (i, argss) => map (fn args => ToyCache.flush (i, args)) argss)
         val doExp =
          fn EDml (origDmlText, failureMode) =>
             let