ziv@2234: structure LruCache : sig ziv@2234: val cache : Cache.cache ziv@2234: end = struct ziv@2234: ziv@2234: ziv@2234: (* Mono *) ziv@2234: ziv@2234: open Mono ziv@2234: ziv@2234: val dummyLoc = ErrorMsg.dummySpan ziv@2234: val stringTyp = (TFfi ("Basis", "string"), dummyLoc) ziv@2234: val optionStringTyp = (TOption stringTyp, dummyLoc) ziv@2234: fun withTyp typ = map (fn exp => (exp, typ)) ziv@2234: ziv@2234: fun ffiAppCache' (func, index, argTyps) = ziv@2265: EFfiApp ("Sqlcache", func ^ Int.toString index, argTyps) ziv@2234: ziv@2234: fun check (index, keys) = ziv@2234: ffiAppCache' ("check", index, withTyp stringTyp keys) ziv@2234: ziv@2234: fun store (index, keys, value) = ziv@2234: ffiAppCache' ("store", index, (value, stringTyp) :: withTyp stringTyp keys) ziv@2234: ziv@2234: fun flush (index, keys) = ziv@2234: ffiAppCache' ("flush", index, withTyp optionStringTyp keys) ziv@2234: ziv@2286: fun lock (index, write) = ziv@2286: ffiAppCache' ((if write then "w" else "r") ^ "lock", index, []) ziv@2286: ziv@2234: ziv@2234: (* Cjr *) ziv@2234: ziv@2234: open Print ziv@2234: open Print.PD ziv@2234: ziv@2234: fun setupQuery {index, params} = ziv@2234: let ziv@2234: ziv@2234: val i = Int.toString index ziv@2234: ziv@2234: fun paramRepeat itemi sep = ziv@2234: let ziv@2234: fun f n = ziv@2234: if n < 0 then "" ziv@2234: else if n = 0 then itemi (Int.toString 0) ziv@2234: else f (n-1) ^ sep ^ itemi (Int.toString n) ziv@2234: in ziv@2234: f (params - 1) ziv@2234: end ziv@2234: ziv@2234: fun paramRepeatRev itemi sep = ziv@2234: let ziv@2234: fun f n = ziv@2234: if n < 0 then "" ziv@2234: else if n = 0 then itemi (Int.toString 0) ziv@2234: else itemi (Int.toString n) ^ sep ^ f (n-1) ziv@2234: in ziv@2234: f (params - 1) ziv@2234: end ziv@2234: ziv@2234: fun paramRepeatInit itemi sep = ziv@2234: if params = 0 then "" else sep ^ paramRepeat itemi sep ziv@2234: ziv@2234: val typedArgs = paramRepeatInit (fn p => "uw_Basis_string p" ^ p) ", " ziv@2234: ziv@2234: val revArgs = paramRepeatRev (fn p => "p" ^ p) ", " ziv@2234: ziv@2234: in ziv@2234: Print.box ziv@2250: [string ("static uw_Sqlcache_Cache cacheStruct" ^ i ^ " = {"), ziv@2285: newline, ziv@2288: string " .lockIn = PTHREAD_RWLOCK_INITIALIZER,", ziv@2288: newline, ziv@2288: string " .lockOut = PTHREAD_RWLOCK_INITIALIZER,", ziv@2234: newline, ziv@2234: string " .table = NULL,", ziv@2234: newline, ziv@2281: string (" .numKeys = " ^ Int.toString params ^ ","), ziv@2281: newline, ziv@2234: string " .timeInvalid = 0,", ziv@2234: newline, ziv@2279: string " .timeNow = 0};", ziv@2234: newline, ziv@2250: string ("static uw_Sqlcache_Cache *cache" ^ i ^ " = &cacheStruct" ^ i ^ ";"), ziv@2234: newline, ziv@2234: newline, ziv@2234: ziv@2288: string ("static void uw_Sqlcache_rlock" ^ i ^ "(uw_context ctx) {"), ziv@2288: newline, ziv@2288: string (" uw_Sqlcache_rlock(ctx, cache" ^ i ^ ");"), ziv@2288: newline, ziv@2288: string "}", ziv@2288: newline, ziv@2288: newline, ziv@2288: ziv@2288: string ("static void uw_Sqlcache_wlock" ^ i ^ "(uw_context ctx) {"), ziv@2288: newline, ziv@2288: string (" uw_Sqlcache_wlock(ctx, cache" ^ i ^ ");"), ziv@2288: newline, ziv@2288: string "}", ziv@2288: newline, ziv@2288: newline, ziv@2288: ziv@2234: string ("static uw_Basis_string uw_Sqlcache_check" ^ i), ziv@2234: string ("(uw_context ctx" ^ typedArgs ^ ") {"), ziv@2234: newline, ziv@2234: string (" char *ks[] = {" ^ revArgs ^ "};"), ziv@2234: newline, ziv@2285: string (" uw_Sqlcache_Value *v = uw_Sqlcache_check(ctx, cache" ^ i ^ ", ks);"), ziv@2234: newline, ziv@2262: (* If the output is null, it means we had too much recursion, so it's a miss. *) ziv@2262: string " if (v && v->output != NULL) {", ziv@2234: newline, adam@2296: (*string (" puts(\"SQLCACHE: hit " ^ i ^ ".\");"), adam@2296: newline,*) ziv@2234: string " uw_write(ctx, v->output);", ziv@2234: newline, ziv@2234: string " return v->result;", ziv@2234: newline, ziv@2234: string " } else {", ziv@2234: newline, adam@2296: (*string (" puts(\"SQLCACHE: miss " ^ i ^ ".\");"), adam@2296: newline,*) ziv@2234: string " uw_recordingStart(ctx);", ziv@2234: newline, ziv@2234: string " return NULL;", ziv@2234: newline, ziv@2234: string " }", ziv@2234: newline, ziv@2234: string "}", ziv@2234: newline, ziv@2234: newline, ziv@2234: ziv@2234: string ("static uw_unit uw_Sqlcache_store" ^ i), ziv@2234: string ("(uw_context ctx, uw_Basis_string s" ^ typedArgs ^ ") {"), ziv@2234: newline, ziv@2234: string (" char *ks[] = {" ^ revArgs ^ "};"), ziv@2234: newline, adam@2297: string (" uw_Sqlcache_Value *v = malloc(sizeof(uw_Sqlcache_Value));"), ziv@2234: newline, ziv@2234: string " v->result = strdup(s);", ziv@2234: newline, ziv@2234: string " v->output = uw_recordingRead(ctx);", ziv@2234: newline, adam@2296: (*string (" puts(\"SQLCACHE: stored " ^ i ^ ".\");"), adam@2296: newline,*) ziv@2285: string (" uw_Sqlcache_store(ctx, cache" ^ i ^ ", ks, v);"), ziv@2234: newline, ziv@2234: string " return uw_unit_v;", ziv@2234: newline, ziv@2234: string "}", ziv@2234: newline, ziv@2234: newline, ziv@2234: ziv@2234: string ("static uw_unit uw_Sqlcache_flush" ^ i), ziv@2234: string ("(uw_context ctx" ^ typedArgs ^ ") {"), ziv@2234: newline, ziv@2234: string (" char *ks[] = {" ^ revArgs ^ "};"), ziv@2234: newline, ziv@2284: string (" uw_Sqlcache_flush(ctx, cache" ^ i ^ ", ks);"), ziv@2234: newline, ziv@2234: string " return uw_unit_v;", ziv@2234: newline, ziv@2234: string "}", ziv@2234: newline, ziv@2234: newline] ziv@2234: end ziv@2234: ziv@2234: val setupGlobal = string "/* No global setup for LRU cache. */" ziv@2234: ziv@2234: ziv@2234: (* Bundled up. *) ziv@2234: ziv@2234: (* For now, use the toy implementation if there are no arguments. *) ziv@2234: fun toyIfNoKeys numKeys implLru implToy args = ziv@2234: if numKeys args = 0 ziv@2234: then implToy args ziv@2234: else implLru args ziv@2234: ziv@2234: val cache = ziv@2286: (* let *) ziv@2286: (* val {check = toyCheck, *) ziv@2286: (* store = toyStore, *) ziv@2286: (* flush = toyFlush, *) ziv@2286: (* setupQuery = toySetupQuery, *) ziv@2286: (* ...} = ToyCache.cache *) ziv@2286: (* in *) ziv@2286: (* {check = toyIfNoKeys (length o #2) check toyCheck, *) ziv@2286: (* store = toyIfNoKeys (length o #2) store toyStore, *) ziv@2286: (* flush = toyIfNoKeys (length o #2) flush toyFlush, *) ziv@2286: {check = check, store = store, flush = flush, lock = lock, ziv@2286: setupQuery = setupQuery, setupGlobal = setupGlobal} ziv@2286: (* end *) ziv@2234: ziv@2234: end