summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/c/urweb.c95
-rw-r--r--src/cache.sml9
-rw-r--r--src/lru_cache.sml29
-rw-r--r--src/sqlcache.sml149
-rw-r--r--src/toy_cache.sml5
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-26 12:57:36 +0000