From c38edb9bd5c21bcc1d21979d40ec8e9d638b6e9c Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Fri, 13 Nov 2015 01:04:32 -0500 Subject: Fix issue with one-element caches. Locking still WIP. --- src/c/urweb.c | 95 ++++++++++++++++++++++------------ src/cache.sml | 9 ++-- src/lru_cache.sml | 29 ++++++----- src/sqlcache.sml | 149 ++++++++++++++++++++++++++++++++++++------------------ src/toy_cache.sml | 5 +- 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 -- cgit v1.2.3