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@2258: let ziv@2258: val m = "Sqlcache" ziv@2258: val f = func ^ Int.toString index ziv@2258: in ziv@2258: Settings.addEffectful (m, f); ziv@2258: EFfiApp (m, f, argTyps) ziv@2258: end 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@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@2234: newline, ziv@2234: string " .table = NULL,", ziv@2234: newline, ziv@2234: string " .timeInvalid = 0,", ziv@2234: newline, ziv@2234: string " .lru = NULL,", ziv@2234: newline, ziv@2234: string (" .height = " ^ Int.toString (params - 1) ^ "};"), ziv@2234: newline, ziv@2250: string ("static uw_Sqlcache_Cache *cache" ^ i ^ " = &cacheStruct" ^ i ^ ";"), ziv@2234: newline, ziv@2234: newline, ziv@2234: 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@2250: string (" uw_Sqlcache_CacheValue *v = uw_Sqlcache_check(cache" ^ i ^ ", ks);"), ziv@2234: newline, ziv@2234: string " if (v) {", ziv@2234: newline, ziv@2234: string (" puts(\"SQLCACHE: hit " ^ i ^ ".\");"), ziv@2234: 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, ziv@2234: string (" puts(\"SQLCACHE: miss " ^ i ^ ".\");"), ziv@2234: 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, ziv@2250: string (" uw_Sqlcache_CacheValue *v = malloc(sizeof(uw_Sqlcache_CacheValue));"), ziv@2234: newline, ziv@2234: string " v->result = strdup(s);", ziv@2234: newline, ziv@2234: string " v->output = uw_recordingRead(ctx);", ziv@2234: newline, ziv@2234: string (" puts(\"SQLCACHE: stored " ^ i ^ ".\");"), ziv@2234: newline, ziv@2250: string (" uw_Sqlcache_store(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@2250: string (" uw_Sqlcache_flush(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@2234: let ziv@2234: val {check = toyCheck, ziv@2234: store = toyStore, ziv@2234: flush = toyFlush, ziv@2234: setupQuery = toySetupQuery, ziv@2234: ...} = ToyCache.cache ziv@2234: in ziv@2234: {check = toyIfNoKeys (length o #2) check toyCheck, ziv@2234: store = toyIfNoKeys (length o #2) store toyStore, ziv@2234: flush = toyIfNoKeys (length o #2) flush toyFlush, ziv@2234: setupQuery = toyIfNoKeys #params setupQuery toySetupQuery, ziv@2234: setupGlobal = setupGlobal} ziv@2234: end ziv@2234: ziv@2234: end