ziv@2233: structure ToyCache : sig ziv@2233: val cache : Cache.cache ziv@2233: end = struct ziv@2233: ziv@2231: ziv@2231: (* Mono *) ziv@2231: ziv@2231: open Mono ziv@2231: ziv@2231: val dummyLoc = ErrorMsg.dummySpan ziv@2231: val stringTyp = (TFfi ("Basis", "string"), dummyLoc) ziv@2231: val optionStringTyp = (TOption stringTyp, dummyLoc) ziv@2231: fun withTyp typ = map (fn exp => (exp, typ)) ziv@2231: ziv@2231: fun ffiAppCache' (func, index, argTyps) = ziv@2259: let ziv@2259: val m = "Sqlcache" ziv@2259: val f = func ^ Int.toString index ziv@2259: in ziv@2259: Settings.addEffectful (m, f); ziv@2259: EFfiApp (m, f, argTyps) ziv@2259: end ziv@2231: ziv@2231: fun check (index, keys) = ziv@2231: ffiAppCache' ("check", index, withTyp stringTyp keys) ziv@2231: ziv@2231: fun store (index, keys, value) = ziv@2231: ffiAppCache' ("store", index, (value, stringTyp) :: withTyp stringTyp keys) ziv@2231: ziv@2231: fun flush (index, keys) = ziv@2231: ffiAppCache' ("flush", index, withTyp optionStringTyp keys) ziv@2231: ziv@2231: ziv@2231: (* Cjr *) ziv@2231: ziv@2231: open Print ziv@2231: open Print.PD ziv@2231: ziv@2231: fun setupQuery {index, params} = ziv@2231: let ziv@2231: ziv@2231: val i = Int.toString index ziv@2231: ziv@2231: fun paramRepeat itemi sep = ziv@2231: let ziv@2231: fun f n = ziv@2231: if n < 0 then "" ziv@2231: else if n = 0 then itemi (Int.toString 0) ziv@2231: else f (n-1) ^ sep ^ itemi (Int.toString n) ziv@2231: in ziv@2231: f (params - 1) ziv@2231: end ziv@2231: ziv@2231: fun paramRepeatInit itemi sep = ziv@2231: if params = 0 then "" else sep ^ paramRepeat itemi sep ziv@2231: ziv@2231: val args = paramRepeatInit (fn p => "uw_Basis_string p" ^ p) ", " ziv@2231: ziv@2231: val decls = paramRepeat (fn p => "uw_Basis_string param" ^ i ^ "_" ziv@2231: ^ p ^ " = NULL;") ziv@2231: "\n" ziv@2231: ziv@2231: val sets = paramRepeat (fn p => "param" ^ i ^ "_" ^ p ziv@2231: ^ " = strdup(p" ^ p ^ ");") ziv@2231: "\n" ziv@2231: ziv@2231: val frees = paramRepeat (fn p => "free(param" ^ i ^ "_" ^ p ^ ");") ziv@2231: "\n" ziv@2231: ziv@2231: val eqs = paramRepeatInit (fn p => "strcmp(param" ^ i ^ "_" ^ p ziv@2231: ^ ", p" ^ p ^ ")") ziv@2231: " || " ziv@2231: ziv@2231: (* Using [!=] instead of [==] to mimic [strcmp]. *) ziv@2231: val eqsNull = paramRepeatInit (fn p => "(p" ^ p ^ " == NULL || " ziv@2231: ^ "!strcmp(param" ^ i ^ "_" ziv@2231: ^ p ^ ", p" ^ p ^ "))") ziv@2231: " && " ziv@2231: ziv@2231: in ziv@2231: Print.box ziv@2231: [string "static char *cacheQuery", ziv@2231: string i, ziv@2231: string " = NULL;", ziv@2231: newline, ziv@2231: string "static char *cacheWrite", ziv@2231: string i, ziv@2231: string " = NULL;", ziv@2231: newline, ziv@2231: string decls, ziv@2231: newline, ziv@2231: string "static uw_Basis_string uw_Sqlcache_check", ziv@2231: string i, ziv@2231: string "(uw_context ctx", ziv@2231: string args, ziv@2231: string ") {", ziv@2231: newline, ziv@2262: string "if (cacheWrite", ziv@2231: string i, ziv@2231: (* ASK: is returning the pointer okay? Should we duplicate? *) ziv@2231: string " == NULL", ziv@2231: string eqs, ziv@2231: string ") {", ziv@2231: newline, ziv@2231: string "puts(\"SQLCACHE: miss ", ziv@2231: string i, ziv@2231: string ".\");", ziv@2231: newline, ziv@2231: string "uw_recordingStart(ctx);", ziv@2231: newline, ziv@2231: string "return NULL;", ziv@2231: newline, ziv@2231: string "} else {", ziv@2231: newline, ziv@2231: string "puts(\"SQLCACHE: hit ", ziv@2231: string i, ziv@2231: string ".\");", ziv@2231: newline, ziv@2262: string " if (cacheWrite", ziv@2231: string i, ziv@2262: string " != NULL) { uw_write(ctx, cacheWrite", ziv@2262: string i, ziv@2262: string "); }", ziv@2231: newline, ziv@2231: string "return cacheQuery", ziv@2231: string i, ziv@2231: string ";", ziv@2231: newline, ziv@2231: string "} };", ziv@2231: newline, ziv@2231: string "static uw_unit uw_Sqlcache_store", ziv@2231: string i, ziv@2231: string "(uw_context ctx, uw_Basis_string s", ziv@2231: string args, ziv@2231: string ") {", ziv@2231: newline, ziv@2231: string "free(cacheQuery", ziv@2231: string i, ziv@2231: string "); free(cacheWrite", ziv@2231: string i, ziv@2231: string ");", ziv@2231: newline, ziv@2231: string frees, ziv@2231: newline, ziv@2231: string "cacheQuery", ziv@2231: string i, ziv@2231: string " = strdup(s); cacheWrite", ziv@2231: string i, ziv@2231: string " = uw_recordingRead(ctx);", ziv@2231: newline, ziv@2231: string sets, ziv@2231: newline, ziv@2231: string "puts(\"SQLCACHE: store ", ziv@2231: string i, ziv@2231: string ".\");", ziv@2231: newline, ziv@2231: string "return uw_unit_v;", ziv@2231: newline, ziv@2231: string "};", ziv@2231: newline, ziv@2231: string "static uw_unit uw_Sqlcache_flush", ziv@2231: string i, ziv@2231: string "(uw_context ctx", ziv@2231: string args, ziv@2231: string ") {", ziv@2231: newline, ziv@2231: string "if (cacheQuery", ziv@2231: string i, ziv@2231: string " != NULL", ziv@2231: string eqsNull, ziv@2231: string ") {", ziv@2231: newline, ziv@2231: string "free(cacheQuery", ziv@2231: string i, ziv@2231: string ");", ziv@2231: newline, ziv@2231: string "cacheQuery", ziv@2231: string i, ziv@2231: string " = NULL;", ziv@2231: newline, ziv@2262: string "free(cacheWrite", ziv@2262: string i, ziv@2262: string ");", ziv@2262: newline, ziv@2262: string "cacheWrite", ziv@2262: string i, ziv@2262: string " = NULL;", ziv@2262: newline, ziv@2231: string "puts(\"SQLCACHE: flush ", ziv@2231: string i, ziv@2231: string ".\");}", ziv@2231: newline, ziv@2231: string "else { puts(\"SQLCACHE: keep ", ziv@2231: string i, ziv@2231: string ".\"); } return uw_unit_v;", ziv@2231: newline, ziv@2231: string "};", ziv@2231: newline, ziv@2231: newline] ziv@2231: end ziv@2231: ziv@2231: val setupGlobal = string "/* No global setup for toy cache. */" ziv@2231: ziv@2233: ziv@2233: (* Bundled up. *) ziv@2233: ziv@2233: val cache = {check = check, store = store, flush = flush, ziv@2233: setupQuery = setupQuery, setupGlobal = setupGlobal} ziv@2233: ziv@2231: end