Fix issue with one-element caches. Locking still WIP.

5 files changed, 189 insertions, 98 deletions

diff --git a/src/c/urweb.c b/src/c/urweb.c
index 4afc7297..02e17a0b 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -4641,18 +4641,27 @@ uw_Sqlcache_Value *uw_Sqlcache_check(uw_context ctx, uw_Sqlcache_Cache *cache, c
   char *buf = key;
   time_t timeInvalid = cache->timeInvalid;
   uw_Sqlcache_Entry *entry;
-  while (numKeys-- > 0) {
-    buf = uw_Sqlcache_keyCopy(buf, keys[numKeys]);
-    size_t len = buf - key;
-    entry = uw_Sqlcache_find(cache, key, len, 1);
+  if (numKeys == 0) {
+    entry = cache->table;
     if (!entry) {
       free(key);
       pthread_rwlock_unlock(&cache->lock);
       return NULL;
     }
-    timeInvalid = uw_Sqlcache_timeMax(timeInvalid, entry->timeInvalid);
+  } else {
+    while (numKeys-- > 0) {
+      buf = uw_Sqlcache_keyCopy(buf, keys[numKeys]);
+      size_t len = buf - key;
+      entry = uw_Sqlcache_find(cache, key, len, 1);
+      if (!entry) {
+        free(key);
+        pthread_rwlock_unlock(&cache->lock);
+        return NULL;
+      }
+      timeInvalid = uw_Sqlcache_timeMax(timeInvalid, entry->timeInvalid);
+    }
+    free(key);
   }
-  free(key);
   // TODO: pass back copy of value and free it in the generated code... or use uw_malloc?
   uw_Sqlcache_Value *value = entry->value;
   pthread_rwlock_unlock(&cache->lock);
@@ -4666,19 +4675,30 @@ void uw_Sqlcache_storeCommitOne(uw_Sqlcache_Cache *cache, char **keys, uw_Sqlcac
   char *buf = key;
   time_t timeNow = uw_Sqlcache_getTimeNow(cache);
   uw_Sqlcache_Entry *entry;
-  while (numKeys-- > 0) {
-    buf = uw_Sqlcache_keyCopy(buf, keys[numKeys]);
-    size_t len = buf - key;
-    entry = uw_Sqlcache_find(cache, key, len, 1);
+  if (numKeys == 0) {
+    entry = cache->table;
     if (!entry) {
       entry = malloc(sizeof(uw_Sqlcache_Entry));
       entry->key = strdup(key);
       entry->value = NULL;
       entry->timeInvalid = 0;
-      uw_Sqlcache_add(cache, entry, len);
+      cache->table = entry;
     }
+  } else {
+    while (numKeys-- > 0) {
+      buf = uw_Sqlcache_keyCopy(buf, keys[numKeys]);
+      size_t len = buf - key;
+      entry = uw_Sqlcache_find(cache, key, len, 1);
+      if (!entry) {
+        entry = malloc(sizeof(uw_Sqlcache_Entry));
+        entry->key = strdup(key);
+        entry->value = NULL;
+        entry->timeInvalid = 0;
+        uw_Sqlcache_add(cache, entry, len);
+      }
+    }
+    free(key);
   }
-  free(key);
   uw_Sqlcache_freeValue(entry->value);
   entry->value = value;
   entry->value->timeValid = timeNow;
@@ -4692,29 +4712,40 @@ void uw_Sqlcache_flushCommitOne(uw_Sqlcache_Cache *cache, char **keys) {
   char *buf = key;
   time_t timeNow = uw_Sqlcache_getTimeNow(cache);
   uw_Sqlcache_Entry *entry;
-  while (numKeys-- > 0) {
-    char *k = keys[numKeys];
-    if (!k) {
-      if (entry) {
-        entry->timeInvalid = timeNow;
-      } else {
-        // Haven't found an entry yet, so the first key was null.
-        cache->timeInvalid = timeNow;
-      }
-      free(key);
-      return;
+  if (numKeys == 0) {
+    puts("flush cache of height 0");
+    entry = cache->table;
+    if (entry) {
+      uw_Sqlcache_freeValue(entry->value);
+      entry->value = NULL;
     }
-    buf = uw_Sqlcache_keyCopy(buf, k);
-    size_t len = buf - key;
-    entry = uw_Sqlcache_find(cache, key, len, 0);
-    if (!entry) {
-      free(key);
-      return;
+  } else {
+    while (numKeys-- > 0) {
+      char *k = keys[numKeys];
+      if (!k) {
+        if (entry) {
+          entry->timeInvalid = timeNow;
+        } else {
+          // Haven't found an entry yet, so the first key was null.
+          cache->timeInvalid = timeNow;
+        }
+        free(key);
+        pthread_rwlock_unlock(&cache->lock);
+        return;
+      }
+      buf = uw_Sqlcache_keyCopy(buf, k);
+      size_t len = buf - key;
+      entry = uw_Sqlcache_find(cache, key, len, 0);
+      if (!entry) {
+        free(key);
+        pthread_rwlock_unlock(&cache->lock);
+        return;
+      }
     }
+    free(key);
+    // All the keys were non-null and the relevant entry is present, so we delete it.
+    uw_Sqlcache_delete(cache, entry);
   }
-  free(key);
-  // All the keys were non-null and the relevant entry is present, so we delete it.
-  uw_Sqlcache_delete(cache, entry);
   pthread_rwlock_unlock(&cache->lock);
 }
 
diff --git a/src/cache.sml b/src/cache.sml
index 8de22e0d..015c3ff1 100644
--- a/src/cache.sml
+++ b/src/cache.sml
@@ -2,13 +2,14 @@ structure Cache = struct
 
 type cache =
      {(* Takes a query ID and parameters (and, for store, the value to
-            store) and gives an FFI call that checks, stores, or flushes the
-            relevant entry. The parameters are strings for check and store and
-            optional strings for flush because some parameters might not be
-            fixed. *)
+         store) and gives an FFI call that checks, stores, or flushes the
+         relevant entry. The parameters are strings for check and store and
+         optional strings for flush because some parameters might not be
+         fixed. *)
       check : int * Mono.exp list -> Mono.exp',
       store : int * Mono.exp list * Mono.exp -> Mono.exp',
       flush : int * Mono.exp list -> Mono.exp',
+      lock : int * bool (* true = write, false = read *) -> Mono.exp',
       (* Generates C needed for FFI calls in check, store, and flush. *)
       setupGlobal : Print.PD.pp_desc,
       setupQuery : {index : int, params : int} -> Print.PD.pp_desc}
diff --git a/src/lru_cache.sml b/src/lru_cache.sml
index b6ffe700..b66becb7 100644
--- a/src/lru_cache.sml
+++ b/src/lru_cache.sml
@@ -24,6 +24,9 @@ fun store (index, keys, value) =
 fun flush (index, keys) =
     ffiAppCache' ("flush", index, withTyp optionStringTyp keys)
 
+fun lock (index, write) =
+    ffiAppCache' ((if write then "w" else "r") ^ "lock", index, [])
+
 
 (* Cjr *)
 
@@ -157,18 +160,18 @@ fun toyIfNoKeys numKeys implLru 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
+    (* 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, *)
+    {check = check, store = store, flush = flush, lock = lock,
+     setupQuery = setupQuery, setupGlobal = setupGlobal}
+    (* end *)
 
 end
diff --git a/src/sqlcache.sml b/src/sqlcache.sml
index 5a748496..2b3b80ae 100644
--- a/src/sqlcache.sml
+++ b/src/sqlcache.sml
@@ -1,6 +1,9 @@
 structure Sqlcache :> SQLCACHE = struct
 
-open Mono
+
+(*********************)
+(* General Utilities *)
+(*********************)
 
 structure IK = struct type ord_key = int val compare = Int.compare end
 structure IS = IntBinarySet
@@ -8,10 +11,9 @@ structure IM = IntBinaryMap
 structure SK = struct type ord_key = string val compare = String.compare end
 structure SS = BinarySetFn(SK)
 structure SM = BinaryMapFn(SK)
+structure IIMM = MultimapFn(structure KeyMap = IM structure ValSet = IS)
 structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS)
 
-(* ASK: how do we deal with heap reallocation? *)
-
 fun id x = x
 
 fun iterate f n x = if n < 0
@@ -20,6 +22,35 @@ fun iterate f n x = if n < 0
                     then x
                     else iterate f (n-1) (f x)
 
+(* From the MLton wiki. *)
+infix  3 <\     fun x <\ f = fn y => f (x, y)     (* Left section      *)
+infix  3 \>     fun f \> y = f y                  (* Left application  *)
+
+fun mapFst f (x, y) = (f x, y)
+
+(* Option monad. *)
+fun obind (x, f) = Option.mapPartial f x
+fun oguard (b, x) = if b then x else NONE
+fun omap f = fn SOME x => SOME (f x) | _ => NONE
+fun omap2 f = fn (SOME x, SOME y) => SOME (f (x,y)) | _ => NONE
+fun osequence ys = List.foldr (omap2 op::) (SOME []) ys
+
+fun indexOf test =
+    let
+        fun f n =
+         fn [] => NONE
+          | (x::xs) => if test x then SOME n else f (n+1) xs
+    in
+        f 0
+    end
+
+
+(************)
+(* Settings *)
+(************)
+
+open Mono
+
 (* Filled in by [addFlushing]. *)
 val ffiInfoRef : {index : int, params : int} list ref = ref []
 
@@ -59,6 +90,11 @@ val alwaysConsolidateRef = ref true
 fun setAlwaysConsolidate b = alwaysConsolidateRef := b
 fun getAlwaysConsolidate () = !alwaysConsolidateRef
 
+
+(************************)
+(* Really Useful Things *)
+(************************)
+
 (* Used to have type context for local variables in MonoUtil functions. *)
 val doBind =
  fn (env, MonoUtil.Exp.RelE (x, t)) => MonoEnv.pushERel env x t NONE
@@ -79,36 +115,26 @@ fun obindDebug printer (x, f) =
                        NONE => (printer (); NONE)
                      | y => y
 
-(*********************)
-(* General Utilities *)
-(*********************)
-
-(* From the MLton wiki. *)
-infix  3 <\     fun x <\ f = fn y => f (x, y)     (* Left section      *)
-infix  3 \>     fun f \> y = f y                  (* Left application  *)
 
-fun mapFst f (x, y) = (f x, y)
-
-(* Option monad. *)
-fun obind (x, f) = Option.mapPartial f x
-fun oguard (b, x) = if b then x else NONE
-fun omap f = fn SOME x => SOME (f x) | _ => NONE
-fun omap2 f = fn (SOME x, SOME y) => SOME (f (x,y)) | _ => NONE
-fun osequence ys = List.foldr (omap2 op::) (SOME []) ys
+(*******************)
+(* Effect Analysis *)
+(*******************)
 
-fun indexOf test =
+(* TODO: test this. *)
+fun transitiveAnalysis doVal state (decls, _) =
     let
-        fun f n =
-         fn [] => NONE
-          | (x::xs) => if test x then SOME n else f (n+1) xs
+        val doDecl =
+         fn ((DVal v, _), state) => doVal (v, state)
+          (* Pass over the list of values a number of times equal to its size,
+             making sure whatever property we're testing propagates everywhere
+             it should. This is analagous to the Bellman-Ford algorithm. *)
+          | ((DValRec vs, _), state) =>
+            iterate (fn state => List.foldl doVal state vs) (length vs) state
+          | (_, state) => state
     in
-        f 0
+        List.foldl doDecl state decls
     end
 
-(*******************)
-(* Effect Analysis *)
-(*******************)
-
 (* Makes an exception for [EWrite] (which is recorded when caching). *)
 fun effectful (effs : IS.set) =
     let
@@ -151,24 +177,13 @@ fun effectful (effs : IS.set) =
     end
 
 (* TODO: test this. *)
-fun effectfulDecls (decls, _) =
-    let
-        fun doVal ((_, name, _, e, _), effs) =
-            if effectful effs MonoEnv.empty e
-            then IS.add (effs, name)
-            else effs
-        val doDecl =
-         fn ((DVal v, _), effs) => doVal (v, effs)
-          (* Repeat the list of declarations a number of times equal to its size,
-             making sure effectfulness propagates everywhere it should. This is
-             analagous to the Bellman-Ford algorithm. *)
-          | ((DValRec vs, _), effs) =>
-            List.foldl doVal effs (List.concat (List.map (fn _ => vs) vs))
-          (* ASK: any other cases? *)
-          | (_, effs) => effs
-    in
-        List.foldl doDecl IS.empty decls
-    end
+fun effectfulDecls file =
+    transitiveAnalysis (fn ((_, name, _, e, _), effs) =>
+                           if effectful effs MonoEnv.empty e
+                           then IS.add (effs, name)
+                           else effs)
+                       IS.empty
+                       file
 
 
 (*********************************)
@@ -1080,9 +1095,7 @@ fun typOfExp' (env : MonoEnv.env) : exp' -> typ option =
   | ERecord fields => SOME (TRecord (map (fn (s, _, t) => (s, t)) fields), dummyLoc)
   | EField (e, s) => (case typOfExp env e of
                           SOME (TRecord fields, _) =>
-                          (case List.find (fn (s', _) => s = s') fields of
-                               SOME (_, t) => SOME t
-                             | _ => NONE)
+                          omap #2 (List.find (fn (s', _) => s = s') fields)
                         | _ => NONE)
   | ECase (_, _, {result, ...}) => SOME result
   | EStrcat _ => SOME (TFfi ("Basis", "string"), dummyLoc)
@@ -1414,6 +1427,46 @@ fun addFlushing ((file, {tableToIndices, indexToInvalInfo, ffiInfo, ...} : state
     end
 
 
+(***********)
+(* Locking *)
+(***********)
+
+(* TODO: do this less evil-ly by not relying on specific FFI names, please? *)
+fun locksNeeded file =
+    transitiveAnalysis
+        (fn ((_, name, _, e, _), state) =>
+            MonoUtil.Exp.fold
+                {typ = #2,
+                 exp = fn (EFfiApp ("Sqlcache", x, _), state as {store, flush}) =>
+                          (case Int.fromString (String.extract (x, 5, NONE)) of
+                               NONE => raise Match
+                             | SOME index =>
+                               if String.isPrefix "store" x
+                               then {store = IIMM.insert (store, name, index), flush = flush}
+                               else if String.isPrefix "flush" x
+                               then {store = store, flush = IIMM.insert (flush, name, index)}
+                               else state)
+                        | _ => state}
+                state
+                e)
+        {store = IIMM.empty, flush = IIMM.empty}
+        file
+
+fun exports (decls, _) =
+    List.foldl (fn ((DExport (_, _, n, _, _, _), _), ns) => IS.add (ns, n)
+                 | ((DTask _, _), _) => raise Fail "Sqlcache doesn't yet support tasks."
+                 | (_, ns) => ns)
+               IS.empty
+               decls
+
+(* fun addLocking file = *)
+(*     let *)
+(*         val whichLocks = locksNeeded file *)
+(*         val needsLocks = exports file *)
+(*     in *)
+
+(*     end *)
+
 (************************)
 (* Compiler Entry Point *)
 (************************)
diff --git a/src/toy_cache.sml b/src/toy_cache.sml
index 377cae01..5c5aa459 100644
--- a/src/toy_cache.sml
+++ b/src/toy_cache.sml
@@ -24,6 +24,9 @@ fun store (index, keys, value) =
 fun flush (index, keys) =
     ffiAppCache' ("flush", index, withTyp optionStringTyp keys)
 
+fun lock (index, keys) =
+    raise Fail "ToyCache doesn't yet implement lock"
+
 
 (* Cjr *)
 
@@ -198,7 +201,7 @@ val setupGlobal = string "/* No global setup for toy cache. */"
 
 (* Bundled up. *)
 
-val cache = {check = check, store = store, flush = flush,
+val cache = {check = check, store = store, flush = flush, lock = lock,
              setupQuery = setupQuery, setupGlobal = setupGlobal}
 
 end