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