# HG changeset patch # User Ziv Scully # Date 1447394672 18000 # Node ID 0bdfec16a01d4ec795cd4b8f0bf13e82051f6b05 # Parent ad3ce1528f71a37090575d4857a30ac8f8e40ffb Fix issue with one-element caches. Locking still WIP. diff -r ad3ce1528f71 -r 0bdfec16a01d src/c/urweb.c --- a/src/c/urweb.c Thu Nov 12 16:36:35 2015 -0500 +++ b/src/c/urweb.c Fri Nov 13 01:04:32 2015 -0500 @@ -4641,18 +4641,27 @@ 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 @@ 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 @@ 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; + if (numKeys == 0) { + puts("flush cache of height 0"); + entry = cache->table; + if (entry) { + uw_Sqlcache_freeValue(entry->value); + entry->value = NULL; + } + } 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; } - free(key); - 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; + } } - buf = uw_Sqlcache_keyCopy(buf, k); - size_t len = buf - key; - entry = uw_Sqlcache_find(cache, key, len, 0); - if (!entry) { - free(key); - 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 -r ad3ce1528f71 -r 0bdfec16a01d src/cache.sml --- a/src/cache.sml Thu Nov 12 16:36:35 2015 -0500 +++ b/src/cache.sml Fri Nov 13 01:04:32 2015 -0500 @@ -2,13 +2,14 @@ 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 -r ad3ce1528f71 -r 0bdfec16a01d src/lru_cache.sml --- a/src/lru_cache.sml Thu Nov 12 16:36:35 2015 -0500 +++ b/src/lru_cache.sml Fri Nov 13 01:04:32 2015 -0500 @@ -24,6 +24,9 @@ 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 @@ 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 -r ad3ce1528f71 -r 0bdfec16a01d src/sqlcache.sml --- a/src/sqlcache.sml Thu Nov 12 16:36:35 2015 -0500 +++ b/src/sqlcache.sml Fri Nov 13 01:04:32 2015 -0500 @@ -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 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 @@ 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 @@ 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 @@ 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 - -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 (*******************) (* Effect Analysis *) (*******************) +(* TODO: test this. *) +fun transitiveAnalysis doVal state (decls, _) = + let + 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 + List.foldl doDecl state decls + end + (* Makes an exception for [EWrite] (which is recorded when caching). *) fun effectful (effs : IS.set) = let @@ -151,24 +177,13 @@ 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 @@ | 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 @@ 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 -r ad3ce1528f71 -r 0bdfec16a01d src/toy_cache.sml --- a/src/toy_cache.sml Thu Nov 12 16:36:35 2015 -0500 +++ b/src/toy_cache.sml Fri Nov 13 01:04:32 2015 -0500 @@ -24,6 +24,9 @@ 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 @@ (* 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