diff options
Diffstat (limited to 'src/lru_cache.sml')
| -rw-r--r-- | src/lru_cache.sml | 203 |
1 files changed, 203 insertions, 0 deletions
diff --git a/src/lru_cache.sml b/src/lru_cache.sml new file mode 100644 index 00000000..81000458 --- /dev/null +++ b/src/lru_cache.sml @@ -0,0 +1,203 @@ +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) + +fun lock (index, write) = + ffiAppCache' ((if write then "w" else "r") ^ "lock", index, []) + + +(* 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) ", " + + val argNums = List.tabulate (params, fn i => "p" ^ Int.toString i) + in + Print.box + [string ("static uw_Sqlcache_Cache cacheStruct" ^ i ^ " = {"), + newline, + string " .lockIn = PTHREAD_RWLOCK_INITIALIZER,", + newline, + string " .lockOut = PTHREAD_RWLOCK_INITIALIZER,", + newline, + string " .table = NULL,", + newline, + string (" .numKeys = " ^ Int.toString params ^ ","), + newline, + string " .timeInvalid = 0,", + newline, + string " .timeNow = 0};", + newline, + string ("static uw_Sqlcache_Cache *cache" ^ i ^ " = &cacheStruct" ^ i ^ ";"), + newline, + newline, + + string ("static void uw_Sqlcache_rlock" ^ i ^ "(uw_context ctx) {"), + newline, + string (" uw_Sqlcache_rlock(ctx, cache" ^ i ^ ");"), + newline, + string "}", + newline, + newline, + + string ("static void uw_Sqlcache_wlock" ^ i ^ "(uw_context ctx) {"), + newline, + string (" uw_Sqlcache_wlock(ctx, cache" ^ i ^ ");"), + newline, + string "}", + newline, + newline, + + string ("static uw_Basis_string uw_Sqlcache_check" ^ i), + string ("(uw_context ctx" ^ typedArgs ^ ") {"), + newline, + string (" char *ks[] = {" ^ revArgs ^ "};"), + newline, + string (" uw_Sqlcache_Value *v = uw_Sqlcache_check(ctx, cache" ^ i ^ ", ks);"), + newline, + (* If the output is null, it means we had too much recursion, so it's a miss. *) + string " if (v && v->output != NULL) {", + newline, + (*string (" puts(\"SQLCACHE: hit " ^ i ^ ".\");"), + newline,*) + string " uw_write(ctx, v->output);", + newline, + string " return v->result;", + newline, + string " } else {", + newline, + (*string (" printf(\"SQLCACHE: miss " ^ i ^ " " ^ String.concatWith ", " (List.tabulate (params, fn _ => "%s")) ^ ".\\n\""), + (case argNums of + [] => Print.box [] + | _ => Print.box [string ", ", + p_list string argNums]), + string ");", + 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 (" uw_Sqlcache_Value *v = malloc(sizeof(uw_Sqlcache_Value));"), + newline, + string " v->result = strdup(s);", + newline, + string " v->output = uw_recordingRead(ctx);", + newline, + (*string (" puts(\"SQLCACHE: stored " ^ i ^ ".\");"), + newline,*) + string (" uw_Sqlcache_store(ctx, 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 (" uw_Sqlcache_flush(ctx, cache" ^ i ^ ", ks);"), + newline, + (*string (" puts(\"SQLCACHE: flushed " ^ i ^ ".\");"), + 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, *) + {check = check, store = store, flush = flush, lock = lock, + setupQuery = setupQuery, setupGlobal = setupGlobal} + (* end *) + +end |