Progress on LRU cache but still more known bugs to fix.

1 files changed, 171 insertions, 0 deletions

diff --git a/src/lru_cache.sml b/src/lru_cache.sml
new file mode 100644
index 00000000..87e939fa
--- /dev/null
+++ b/src/lru_cache.sml
@@ -0,0 +1,171 @@
+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)
+
+
+(* 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) ", "
+
+    in
+        Print.box
+            [string ("static Cache cacheStruct" ^ i ^ " = {"),
+             newline,
+             string "  .table = NULL,",
+             newline,
+             string "  .timeInvalid = 0,",
+             newline,
+             string "  .lru = NULL,",
+             newline,
+             string ("  .height = " ^ Int.toString (params - 1) ^ "};"),
+             newline,
+             string ("static Cache *cache" ^ i ^ " = &cacheStruct" ^ i ^ ";"),
+             newline,
+             newline,
+
+             string ("static uw_Basis_string uw_Sqlcache_check" ^ i),
+             string ("(uw_context ctx" ^ typedArgs ^ ") {"),
+             newline,
+             string ("  char *ks[] = {" ^ revArgs ^ "};"),
+             newline,
+             string ("  CacheValue *v = check(cache" ^ i ^ ", ks);"),
+             newline,
+             string "  if (v) {",
+             newline,
+             string ("    puts(\"SQLCACHE: hit " ^ i ^ ".\");"),
+             newline,
+             string "    uw_write(ctx, v->output);",
+             newline,
+             string "    return v->result;",
+             newline,
+             string "  } else {",
+             newline,
+             string ("    puts(\"SQLCACHE: miss " ^ i ^ ".\");"),
+             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 ("  CacheValue *v = malloc(sizeof(CacheValue));"),
+             newline,
+             string "  v->result = strdup(s);",
+             newline,
+             string "  v->output = uw_recordingRead(ctx);",
+             newline,
+             string ("  puts(\"SQLCACHE: stored " ^ i ^ ".\");"),
+             newline,
+             string ("  store(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 ("  flush(cache" ^ i ^ ", ks);"),
+             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,
+         setupQuery = toyIfNoKeys #params setupQuery toySetupQuery,
+         setupGlobal = setupGlobal}
+    end
+
+end