Progress on LRU cache but still more known bugs to fix.

4 files changed, 381 insertions, 53 deletions

diff --git a/src/c/urweb.c b/src/c/urweb.c
index 53344c5e..e0fd503c 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -22,6 +22,8 @@
 
 #include "types.h"
 
+#include "uthash.h"
+
 uw_unit uw_unit_v = 0;
 
 
@@ -4494,3 +4496,148 @@ int uw_remoteSock(uw_context ctx) {
 void uw_set_remoteSock(uw_context ctx, int sock) {
   ctx->remoteSock = sock;
 }
+
+
+// Sqlcache
+
+void listDelete(CacheList *list, CacheEntry *entry) {
+  if (list->first == entry) {
+    list->first = entry->next;
+  }
+  if (list->last == entry) {
+    list->last = entry->prev;
+  }
+  if (entry->prev) {
+    entry->prev->next = entry->next;
+  }
+  if (entry->next) {
+    entry->next->prev = entry->prev;
+  }
+  entry->prev = NULL;
+  entry->next = NULL;
+  --(list->size);
+}
+
+void listAdd(CacheList *list, CacheEntry *entry) {
+  if (list->last) {
+    list->last->next = entry;
+    entry->prev = list->last;
+    list->last = entry;
+  } else {
+    list->first = entry;
+    list->last = entry;
+  }
+  ++(list->size);
+}
+
+void listBump(CacheList *list, CacheEntry *entry) {
+  listDelete(list, entry);
+  listAdd(list, entry);
+}
+
+// TODO: deal with time properly.
+
+time_t getTimeNow() {
+  return time(NULL);
+}
+
+time_t timeMax(time_t x, time_t y) {
+  return difftime(x, y) > 0 ? x : y;
+}
+
+void freeCacheValue(CacheValue *value) {
+  if (value) {
+    free(value->result);
+    free(value->output);
+    free(value);
+  }
+}
+
+void delete(Cache *cache, CacheEntry* entry) {
+  //listDelete(cache->lru, entry);
+  HASH_DELETE(hh, cache->table, entry);
+  freeCacheValue(entry->value);
+  free(entry->key);
+  free(entry);
+}
+
+CacheValue *checkHelper(Cache *cache, char **keys, int timeInvalid) {
+  char *key = keys[cache->height];
+  CacheEntry *entry;
+  HASH_FIND(hh, cache->table, key, strlen(key), entry);
+  timeInvalid = timeMax(timeInvalid, cache->timeInvalid);
+  if (entry && difftime(entry->timeValid, timeInvalid) > 0) {
+    if (cache->height == 0) {
+      // At height 0, entry->value is the desired value.
+      //listBump(cache->lru, entry);
+      return entry->value;
+    } else {
+      // At height n+1, entry->value is a pointer to a cache at heignt n.
+      return checkHelper(entry->value, keys, timeInvalid);
+    }
+  } else {
+    return NULL;
+  }
+}
+
+CacheValue *check(Cache *cache, char **keys) {
+  return checkHelper(cache, keys, 0);
+}
+
+void storeHelper(Cache *cache, char **keys, CacheValue *value, int timeNow) {
+  CacheEntry *entry;
+  char *key = keys[cache->height];
+  HASH_FIND(hh, cache->table, key, strlen(key), entry);
+  if (!entry) {
+    entry = malloc(sizeof(CacheEntry));
+    entry->key = strdup(key);
+    entry->value = NULL;
+    HASH_ADD_KEYPTR(hh, cache->table, entry->key, strlen(entry->key), entry);
+  }
+  entry->timeValid = timeNow;
+  if (cache->height == 0) {
+    //listAdd(cache->lru, entry);
+    freeCacheValue(entry->value);
+    entry->value = value;
+    //if (cache->lru->size > MAX_SIZE) {
+      //delete(cache, cache->lru->first);
+      // TODO: return flushed value.
+    //}
+  } else {
+    if (!entry->value) {
+      Cache *newCache = malloc(sizeof(Cache));
+      newCache->table = NULL;
+      newCache->timeInvalid = timeNow;
+      newCache->lru = cache->lru;
+      newCache->height = cache->height - 1;
+      entry->value = newCache;
+    }
+    storeHelper(entry->value, keys, value, timeNow);
+  }
+}
+
+void store(Cache *cache, char **keys, CacheValue *value) {
+  storeHelper(cache, keys, value, getTimeNow());
+}
+
+void flushHelper(Cache *cache, char **keys, int timeNow) {
+  CacheEntry *entry;
+  char *key = keys[cache->height];
+  if (key) {
+    HASH_FIND(hh, cache->table, key, strlen(key), entry);
+    if (entry) {
+      if (cache->height == 0) {
+        delete(cache, entry);
+      } else {
+        flushHelper(entry->value, keys, timeNow);
+      }
+    }
+  } else {
+    // Null key means invalidate the entire subtree.
+    cache->timeInvalid = timeNow;
+  }
+}
+
+void flush(Cache *cache, char **keys) {
+  flushHelper(cache, keys, getTimeNow());
+}
diff --git a/src/lru_cache.sml b/src/lru_cache.sml
new file mode 100644
index 00000000..87e939fa
--- /dev/null
+++ b/src/lru_cache.sml
@@ -0,0 +1,171 @@
+structure LruCache : sig
+    val cache : Cache.cache
+end = struct
+
+
+(* Mono *)
+
+open Mono
+
+val dummyLoc = ErrorMsg.dummySpan
+val stringTyp = (TFfi ("Basis", "string"), dummyLoc)
+val optionStringTyp = (TOption stringTyp, dummyLoc)
+fun withTyp typ = map (fn exp => (exp, typ))
+
+fun ffiAppCache' (func, index, argTyps) =
+    EFfiApp ("Sqlcache", func ^ Int.toString index, argTyps)
+
+fun check (index, keys) =
+    ffiAppCache' ("check", index, withTyp stringTyp keys)
+
+fun store (index, keys, value) =
+    ffiAppCache' ("store", index, (value, stringTyp) :: withTyp stringTyp keys)
+
+fun flush (index, keys) =
+    ffiAppCache' ("flush", index, withTyp optionStringTyp keys)
+
+
+(* Cjr *)
+
+open Print
+open Print.PD
+
+fun setupQuery {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 paramRepeatRev itemi sep =
+            let
+                fun f n =
+                    if n < 0 then ""
+                    else if n = 0 then itemi (Int.toString 0)
+                    else itemi (Int.toString n) ^ sep ^ f (n-1)
+            in
+                f (params - 1)
+            end
+
+        fun paramRepeatInit itemi sep =
+            if params = 0 then "" else sep ^ paramRepeat itemi sep
+
+        val typedArgs = paramRepeatInit (fn p => "uw_Basis_string p" ^ p) ", "
+
+        val revArgs = paramRepeatRev (fn p => "p" ^ p) ", "
+
+    in
+        Print.box
+            [string ("static Cache cacheStruct" ^ i ^ " = {"),
+             newline,
+             string "  .table = NULL,",
+             newline,
+             string "  .timeInvalid = 0,",
+             newline,
+             string "  .lru = NULL,",
+             newline,
+             string ("  .height = " ^ Int.toString (params - 1) ^ "};"),
+             newline,
+             string ("static Cache *cache" ^ i ^ " = &cacheStruct" ^ i ^ ";"),
+             newline,
+             newline,
+
+             string ("static uw_Basis_string uw_Sqlcache_check" ^ i),
+             string ("(uw_context ctx" ^ typedArgs ^ ") {"),
+             newline,
+             string ("  char *ks[] = {" ^ revArgs ^ "};"),
+             newline,
+             string ("  CacheValue *v = check(cache" ^ i ^ ", ks);"),
+             newline,
+             string "  if (v) {",
+             newline,
+             string ("    puts(\"SQLCACHE: hit " ^ i ^ ".\");"),
+             newline,
+             string "    uw_write(ctx, v->output);",
+             newline,
+             string "    return v->result;",
+             newline,
+             string "  } else {",
+             newline,
+             string ("    puts(\"SQLCACHE: miss " ^ i ^ ".\");"),
+             newline,
+             string "    uw_recordingStart(ctx);",
+             newline,
+             string "    return NULL;",
+             newline,
+             string "  }",
+             newline,
+             string "}",
+             newline,
+             newline,
+
+             string ("static uw_unit uw_Sqlcache_store" ^ i),
+             string ("(uw_context ctx, uw_Basis_string s" ^ typedArgs ^ ") {"),
+             newline,
+             string ("  char *ks[] = {" ^ revArgs ^ "};"),
+             newline,
+             string ("  CacheValue *v = malloc(sizeof(CacheValue));"),
+             newline,
+             string "  v->result = strdup(s);",
+             newline,
+             string "  v->output = uw_recordingRead(ctx);",
+             newline,
+             string ("  puts(\"SQLCACHE: stored " ^ i ^ ".\");"),
+             newline,
+             string ("  store(cache" ^ i ^ ", ks, v);"),
+             newline,
+             string "  return uw_unit_v;",
+             newline,
+             string "}",
+             newline,
+             newline,
+
+             string ("static uw_unit uw_Sqlcache_flush" ^ i),
+             string ("(uw_context ctx" ^ typedArgs ^ ") {"),
+             newline,
+             string ("  char *ks[] = {" ^ revArgs ^ "};"),
+             newline,
+             string ("  flush(cache" ^ i ^ ", ks);"),
+             newline,
+             string "  return uw_unit_v;",
+             newline,
+             string "}",
+             newline,
+             newline]
+    end
+
+val setupGlobal = string "/* No global setup for LRU cache. */"
+
+
+(* Bundled up. *)
+
+(* For now, use the toy implementation if there are no arguments. *)
+fun toyIfNoKeys numKeys implLru implToy args =
+    if numKeys args = 0
+    then implToy args
+    else implLru args
+
+val cache =
+    let
+        val {check = toyCheck,
+             store = toyStore,
+             flush = toyFlush,
+             setupQuery = toySetupQuery,
+             ...} = ToyCache.cache
+    in
+        {check = toyIfNoKeys (length o #2) check toyCheck,
+         store = toyIfNoKeys (length o #2) store toyStore,
+         flush = toyIfNoKeys (length o #2) flush toyFlush,
+         setupQuery = toyIfNoKeys #params setupQuery toySetupQuery,
+         setupGlobal = setupGlobal}
+    end
+
+end
diff --git a/src/sources b/src/sources
index aaf640ca..0608d710 100644
--- a/src/sources
+++ b/src/sources
@@ -177,6 +177,7 @@ $(SRC)/multimap_fn.sml
 
 $(SRC)/cache.sml
 $(SRC)/toy_cache.sml
+$(SRC)/lru_cache.sml
 
 $(SRC)/sqlcache.sig
 $(SRC)/sqlcache.sml
diff --git a/src/sqlcache.sml b/src/sqlcache.sml
index 3082904c..bf9ee77a 100644
--- a/src/sqlcache.sml
+++ b/src/sqlcache.sml
@@ -39,7 +39,7 @@ val ffiEffectful =
                      andalso not (m = "Basis" andalso SS.member (fs, f))
     end
 
-val cache = ref ToyCache.cache
+val cache = ref LruCache.cache
 fun setCache c = cache := c
 fun getCache () = !cache
 
@@ -52,8 +52,8 @@ fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : exp ->
        false, then expression is definitely not effectful if effs is fully
        populated. The intended pattern is to use this a number of times equal
        to the number of declarations in a file, Bellman-Ford style. *)
-    (* TODO: make incrementing of bound less janky, probably by using [MonoUtil]
-       instead of all this. *)
+    (* TODO: make incrementing of the number of bound variables cleaner,
+       probably by using [MonoUtil] instead of all this. *)
     let
         (* DEBUG: remove printing when done. *)
         fun tru msg = if doPrint then (print (msg ^ "\n"); true) else true
@@ -138,14 +138,14 @@ val effectfulMap =
 
 (* Boolean formula normalization. *)
 
-datatype normalForm = Cnf | Dnf
+datatype junctionType = Conj | Disj
 
 datatype 'atom formula =
          Atom of 'atom
        | Negate of 'atom formula
-       | Combo of normalForm * 'atom formula list
+       | Combo of junctionType * 'atom formula list
 
-val flipNf = fn Cnf => Dnf | Dnf => Cnf
+val flipJt = fn Conj => Disj | Disj => Conj
 
 fun bind xs f = List.concat (map f xs)
 
@@ -158,7 +158,7 @@ val rec cartesianProduct : 'a list list -> 'a list list =
 fun pushNegate (negate : 'atom -> 'atom) (negating : bool) =
  fn Atom x => Atom (if negating then negate x else x)
   | Negate f => pushNegate negate (not negating) f
-  | Combo (n, fs) => Combo (if negating then flipNf n else n, map (pushNegate negate negating) fs)
+  | Combo (n, fs) => Combo (if negating then flipJt n else n, map (pushNegate negate negating) fs)
 
 val rec flatten =
  fn Combo (n, fs) =>
@@ -170,17 +170,17 @@ val rec flatten =
                          (map flatten fs))
   | f => f
 
-fun normalize' (negate : 'atom -> 'atom) (norm : normalForm) =
+fun normalize' (negate : 'atom -> 'atom) (junc : junctionType) =
  fn Atom x => [[x]]
-  | Negate f => map (map negate) (normalize' negate (flipNf norm) f)
-  | Combo (n, fs) =>
+  | Negate f => map (map negate) (normalize' negate (flipJt junc) f)
+  | Combo (j, fs) =>
     let
-        val fss = bind fs (normalize' negate n)
+        val fss = bind fs (normalize' negate j)
     in
-        if n = norm then fss else cartesianProduct fss
+        if j = junc then fss else cartesianProduct fss
     end
 
-fun normalize negate norm = normalize' negate norm o flatten o pushNegate negate false
+fun normalize negate junc = normalize' negate junc o flatten o pushNegate negate false
 
 fun mapFormula mf =
  fn Atom x => Atom (mf x)
@@ -200,36 +200,29 @@ datatype atomExp =
        | Prim of Prim.t
        | Field of string * string
 
-val equalAtomExp =
-    let
-        val isEqual = fn EQUAL => true | _ => false
-    in
-     fn (QueryArg n1, QueryArg n2) => n1 = n2
-      | (DmlRel n1, DmlRel n2) => n1 = n2
-      | (Prim p1, Prim p2) => isEqual (Prim.compare (p1, p2))
-      | (Field (t1, f1), Field (t2, f2)) => isEqual (String.compare (t1 ^ "." ^ f1, t2 ^ "." ^ f2))
-      | _ => false
-    end
-
 structure AtomExpKey : ORD_KEY = struct
 
-type ord_key = atomExp
-
-val compare =
- fn (QueryArg n1, QueryArg n2) => Int.compare (n1, n2)
-  | (QueryArg _, _) => LESS
-  | (_, QueryArg _) => GREATER
-  | (DmlRel n1, DmlRel n2) => Int.compare (n1, n2)
-  | (DmlRel _, _) => LESS
-  | (_, DmlRel _) => GREATER
-  | (Prim p1, Prim p2) => Prim.compare (p1, p2)
-  | (Prim _, _) => LESS
-  | (_, Prim _) => GREATER
-  | (Field (t1, f1), Field (t2, f2)) => String.compare (t1 ^ "." ^ f1, t2 ^ "." ^ f2)
+    type ord_key = atomExp
+
+    val compare =
+     fn (QueryArg n1, QueryArg n2) => Int.compare (n1, n2)
+      | (QueryArg _, _) => LESS
+      | (_, QueryArg _) => GREATER
+      | (DmlRel n1, DmlRel n2) => Int.compare (n1, n2)
+      | (DmlRel _, _) => LESS
+      | (_, DmlRel _) => GREATER
+      | (Prim p1, Prim p2) => Prim.compare (p1, p2)
+      | (Prim _, _) => LESS
+      | (_, Prim _) => GREATER
+      | (Field (t1, f1), Field (t2, f2)) =>
+        case String.compare (t1, t2) of
+            EQUAL => String.compare (f1, f2)
+          | ord => ord
 
 end
 
 structure UF = UnionFindFn(AtomExpKey)
+
 val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula
                    * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula
                    -> atomExp IM.map list =
@@ -246,7 +239,9 @@ val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula
             o List.mapPartial toKnownEquality
         fun addToEqs (eqs, n, e) =
             case IM.find (eqs, n) of
-                (* Comparing to a constant seems better? *)
+                (* Comparing to a constant is probably better than comparing to
+                   a variable? Checking that an existing constant matches a new
+                   one is handled by [accumulateEqs]. *)
                 SOME (Prim _) => eqs
               | _ => IM.insert (eqs, n, e)
         val accumulateEqs =
@@ -263,6 +258,9 @@ val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula
           (* TODO: deal with equalities involving just [DmlRel]s and [Prim]s.
              This would involve guarding the invalidation with a check for the
              relevant comparisons. *)
+          (* DEBUG: remove these print statements. *)
+          (* | ((DmlRel r, Prim p), eqso) => (print ("sadness " ^ Int.toString r ^ " = " ^ Prim.toString p ^ "\n"); eqso) *)
+          (* | ((Prim p, DmlRel r), eqso) => (print ("sadness " ^ Int.toString r ^ " = " ^ Prim.toString p ^ "\n"); eqso) *)
           | (_, eqso) => eqso
         val eqsOfClass : atomExp list -> atomExp IM.map option =
             List.foldl accumulateEqs (SOME IM.empty)
@@ -275,7 +273,8 @@ val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula
                   | Sql.Field tf => SOME (Field tf)
                   | Sql.Inj (EPrim p, _) => SOME (Prim p)
                   | Sql.Inj (ERel n, _) => SOME (rel n)
-                  (* We can't deal with anything else. *)
+                  (* We can't deal with anything else, e.g., CURRENT_TIMESTAMP
+                     becomes Sql.Unmodeled, which becomes NONE here. *)
                   | _ => NONE
             in
                 (cmp, qa e1, qa e2)
@@ -302,17 +301,17 @@ val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula
             List.foldr (fn (SOME eqs, SOME acc) => SOME (IM.unionWith #1 (eqs, acc)) | _ => NONE)
                        (SOME IM.empty)
         fun dnf (fQuery, fDml) =
-            normalize negateCmp Dnf (Combo (Cnf, [markQuery fQuery, markDml fDml]))
+            normalize negateCmp Disj (Combo (Conj, [markQuery fQuery, markDml fDml]))
     in
         List.mapPartial (mergeEqs o map eqsOfClass o equivClasses) o dnf
     end
 
 val rec sqexpToFormula =
- fn Sql.SqTrue => Combo (Cnf, [])
-  | Sql.SqFalse => Combo (Dnf, [])
+ fn Sql.SqTrue => Combo (Conj, [])
+  | Sql.SqFalse => Combo (Disj, [])
   | Sql.SqNot e => Negate (sqexpToFormula e)
   | Sql.Binop (Sql.RCmp c, e1, e2) => Atom (c, e1, e2)
-  | Sql.Binop (Sql.RLop l, p1, p2) => Combo (case l of Sql.And => Cnf | Sql.Or => Dnf,
+  | Sql.Binop (Sql.RLop l, p1, p2) => Combo (case l of Sql.And => Conj | Sql.Or => Disj,
                                              [sqexpToFormula p1, sqexpToFormula p2])
   (* ASK: any other sqexps that can be props? *)
   | _ => raise Match
@@ -332,13 +331,13 @@ fun renameTables tablePairs =
     end
 
 val rec queryToFormula =
- fn Sql.Query1 {Where = NONE, ...} => Combo (Cnf, [])
+ fn Sql.Query1 {Where = NONE, ...} => Combo (Conj, [])
   | Sql.Query1 {From = tablePairs, Where = SOME e, ...} =>
     renameTables tablePairs (sqexpToFormula e)
-  | Sql.Union (q1, q2) => Combo (Dnf, [queryToFormula q1, queryToFormula q2])
+  | Sql.Union (q1, q2) => Combo (Disj, [queryToFormula q1, queryToFormula q2])
 
 fun valsToFormula (table, vals) =
-    Combo (Cnf, map (fn (field, v) => Atom (Sql.Eq, Sql.Field (table, field), v)) vals)
+    Combo (Conj, map (fn (field, v) => Atom (Sql.Eq, Sql.Field (table, field), v)) vals)
 
 val rec dmlToFormula =
  fn Sql.Insert (table, vals) => valsToFormula (table, vals)
@@ -354,8 +353,8 @@ val rec dmlToFormula =
         val mark = mapFormula (fn (cmp, e1, e2) => (cmp, markField e1, markField e2))
     in
         renameTables [(table, "T")]
-                     (Combo (Dnf, [Combo (Cnf, [fVals, mark fWhere]),
-                                   Combo (Cnf, [mark fVals, fWhere])]))
+                     (Combo (Disj, [Combo (Conj, [fVals, mark fWhere]),
+                                   Combo (Conj, [mark fVals, fWhere])]))
     end
 
 val rec tablesQuery =
@@ -370,6 +369,13 @@ val tableDml =
 
 (* Program instrumentation. *)
 
+val varName =
+    let
+        val varNumber = ref 0
+    in
+        fn s => (varNumber := !varNumber + 1; s ^ Int.toString (!varNumber))
+    end
+
 val {check, store, flush, ...} = getCache ()
 
 val dummyLoc = ErrorMsg.dummySpan
@@ -412,8 +418,8 @@ fun cacheWrap (query, i, urlifiedRel0, resultTyp, args) =
     in
         ECase (check,
                [((PNone stringTyp, loc),
-                 (ELet ("q", resultTyp, query, (ESeq (store, rel0), loc)), loc)),
-                ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc),
+                 (ELet (varName "q", resultTyp, query, (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 = stringTyp, result = resultTyp})
@@ -454,7 +460,7 @@ fun factorOutNontrivial text =
                 chunks
         fun wrapLets e' =
             (* Important that this is foldl (to oppose foldr above). *)
-            List.foldl (fn (v, e') => ELet ("sqlArg", stringTyp, v, (e', loc)))
+            List.foldl (fn (v, e') => ELet (varName "sqlArg", stringTyp, v, (e', loc)))
                        e'
                        newVariables
         val numArgs = length newVariables
@@ -482,6 +488,7 @@ fun addChecking file =
                                                 exps = exps},
                                         dummyLoc)
                 val (EQuery {query = queryText, ...}, _) = queryExp
+                (* DEBUG: we can remove the following line at some point. *)
                 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
@@ -530,9 +537,11 @@ fun invalidations ((query, numArgs), dml) =
         (* 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
+         fn ([], []) => (print "hey!\n"; true)
           | (NONE :: xs, _ :: ys) => madeRedundantBy (xs, ys)
-          | (SOME x :: xs, SOME y :: ys) => equalAtomExp (x, y) andalso madeRedundantBy (xs, ys)
+          | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of
+                                                 EQUAL => madeRedundantBy (xs, ys)
+                                               | _ => false)
           | _ => false
         fun removeRedundant' (xss, yss) =
             case xss of