summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Ziv Scully <ziv@mit.edu>2015-05-06 14:50:29 -0400
committerGravatar Ziv Scully <ziv@mit.edu>2015-05-06 14:50:29 -0400
commitf242d9d14317ee01328b8a071502133696f78aa8 (patch)
treecad1a3757e46ac47962bc76e1175d4149a88e765
parent7b20c054a5362ababbf699e19407ecc38bb747ec (diff)
Factor out cache implementation from Sqlcache.
-rw-r--r--src/cjr_print.sml106
-rw-r--r--src/sources2
-rw-r--r--src/sqlcache.sml52
3 files changed, 19 insertions, 141 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 1b1d656d..12ad309a 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -3404,111 +3404,7 @@ fun p_file env (ds, ps) =
newline,
(* For sqlcache. *)
- box (List.map
- (fn {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 paramRepeatInit itemi sep =
- if params = 0 then "" else sep ^ paramRepeat itemi sep
- val args = paramRepeatInit (fn p => "uw_Basis_string p" ^ p) ", "
- val decls = paramRepeat (fn p => "uw_Basis_string param" ^ i ^ "_"
- ^ p ^ " = NULL;")
- "\n"
- val sets = paramRepeat (fn p => "param" ^ i ^ "_" ^ p
- ^ " = strdup(p" ^ p ^ ");")
- "\n"
- val frees = paramRepeat (fn p => "free(param" ^ i ^ "_" ^ p ^ ");")
- "\n"
- val eqs = paramRepeatInit (fn p => "strcmp(param" ^ i ^ "_" ^ p
- ^ ", p" ^ p ^ ")")
- " || "
- (* Using [!=] instead of [==] to mimic [strcmp]. *)
- val eqsNull = paramRepeatInit (fn p => "(p" ^ p ^ " == NULL || "
- ^ "!strcmp(param" ^ i ^ "_"
- ^ p ^ ", p" ^ p ^ "))")
- " && "
- in box [string "static char *cacheQuery",
- string i,
- string " = NULL;",
- newline,
- string "static char *cacheWrite",
- string i,
- string " = NULL;",
- newline,
- string decls,
- newline,
- string "static uw_Basis_string uw_Sqlcache_check",
- string i,
- string "(uw_context ctx",
- string args,
- string ") {\n if (cacheQuery",
- string i,
- (* ASK: is returning the pointer okay? Should we duplicate? *)
- string " == NULL",
- string eqs,
- string ") {\n puts(\"SQLCACHE: miss ",
- string i,
- string ".\");\n uw_recordingStart(ctx);\n return NULL;\n } else {\n puts(\"SQLCACHE: hit ",
- string i,
- string ".\");\n uw_write(ctx, cacheWrite",
- string i,
- string ");\n return cacheQuery",
- string i,
- string ";\n } };",
- newline,
- string "static uw_unit uw_Sqlcache_store",
- string i,
- string "(uw_context ctx, uw_Basis_string s",
- string args,
- string ") {\n free(cacheQuery",
- string i,
- string "); free(cacheWrite",
- string i,
- string ");",
- newline,
- string frees,
- newline,
- string "cacheQuery",
- string i,
- string " = strdup(s); cacheWrite",
- string i,
- string " = uw_recordingRead(ctx);",
- newline,
- string sets,
- newline,
- string "puts(\"SQLCACHE: store ",
- string i,
- string ".\");\n return uw_unit_v;\n };",
- newline,
- string "static uw_unit uw_Sqlcache_flush",
- string i,
- string "(uw_context ctx",
- string args,
- string ") {\n if (cacheQuery",
- string i,
- string " != NULL",
- string eqsNull,
- string ") {\n free(cacheQuery",
- string i,
- string ");\n cacheQuery",
- string i,
- string " = NULL;\n puts(\"SQLCACHE: flush ",
- string i,
- string ".\");}\n else { puts(\"SQLCACHE: keep ",
- string i,
- string ".\"); } return uw_unit_v;\n };",
- newline,
- newline]
- end)
- (Sqlcache.getFfiInfo ())),
+ box (List.map ToyCache.setupQuery (Sqlcache.getFfiInfo ())),
newline,
p_list_sep newline (fn x => x) pds,
diff --git a/src/sources b/src/sources
index 33c01f94..05897cd4 100644
--- a/src/sources
+++ b/src/sources
@@ -175,6 +175,8 @@ $(SRC)/union_find_fn.sml
$(SRC)/multimap_fn.sml
+$(SRC)/toy_cache.sml
+
$(SRC)/sqlcache.sig
$(SRC)/sqlcache.sml
diff --git a/src/sqlcache.sml b/src/sqlcache.sml
index f60555e8..931c6737 100644
--- a/src/sqlcache.sml
+++ b/src/sqlcache.sml
@@ -43,7 +43,7 @@ val ffiEffectful =
(* Effect analysis. *)
(* Makes an exception for [EWrite] (which is recorded when caching). *)
-fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : Mono.exp -> bool =
+fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : exp -> bool =
(* If result is true, expression is definitely effectful. If result is
false, then expression is definitely not effectful if effs is fully
populated. The intended pattern is to use this a number of times equal
@@ -183,6 +183,7 @@ fun mapFormula mf =
| Negate f => Negate (mapFormula mf f)
| Combo (n, fs) => Combo (n, map (mapFormula mf) fs)
+
(* SQL analysis. *)
val rec chooseTwos : 'a list -> ('a * 'a) list =
@@ -365,33 +366,21 @@ val tableDml =
(* Program instrumentation. *)
-fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), ErrorMsg.dummySpan)
+val dummyLoc = ErrorMsg.dummySpan
+
+fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), dummyLoc)
-val stringTyp = (TFfi ("Basis", "string"), ErrorMsg.dummySpan)
+val stringTyp = (TFfi ("Basis", "string"), dummyLoc)
val sequence =
fn (exp :: exps) =>
let
- val loc = ErrorMsg.dummySpan
+ val loc = dummyLoc
in
List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps
end
| _ => raise Match
-(* TODO: factor out. *)
-fun ffiAppCache' (func, index, args) : Mono.exp' =
- EFfiApp ("Sqlcache", func ^ Int.toString index, args)
-
-fun ffiAppCache (func, index, args) : Mono.exp =
- (ffiAppCache' (func, index, args), ErrorMsg.dummySpan)
-
-val varPrefix = "queryResult"
-
-fun indexOfName varName =
- if String.isPrefix varPrefix varName
- then Int.fromString (String.extract (varName, String.size varPrefix, NONE))
- else NONE
-
(* Always increments negative indices because that's what we need later. *)
fun incRelsBound bound inc =
MonoUtil.Exp.mapB
@@ -407,13 +396,12 @@ val incRels = incRelsBound 0
fun cacheWrap (query, i, urlifiedRel0, resultTyp, args) =
let
val () = ffiInfo := {index = i, params = length args} :: !ffiInfo
- val loc = ErrorMsg.dummySpan
+ val loc = dummyLoc
(* We ensure before this step that all arguments aren't effectful.
by turning them into local variables as needed. *)
- val argTyps = map (fn e => (e, stringTyp)) args
- val argTypsInc = map (fn (e, typ) => (incRels 1 e, typ)) argTyps
- val check = ffiAppCache ("check", i, argTyps)
- val store = ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argTypsInc)
+ val argsInc = map (incRels 1) args
+ val check = (ToyCache.check (i, args), dummyLoc)
+ val store = (ToyCache.store (i, argsInc, urlifiedRel0), dummyLoc)
val rel0 = (ERel 0, loc)
in
ECase (check,
@@ -436,7 +424,7 @@ fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ()
fun factorOutNontrivial text =
let
- val loc = ErrorMsg.dummySpan
+ val loc = dummyLoc
fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
val chunks = Sql.chunkify text
val (newText, newVariables) =
@@ -486,10 +474,10 @@ fun addChecking file =
body = body,
tables = tables,
exps = exps},
- ErrorMsg.dummySpan)
+ dummyLoc)
val (EQuery {query = queryText, ...}, _) = queryExp
val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText))
- val args = List.tabulate (numArgs, fn n => (ERel n, ErrorMsg.dummySpan))
+ val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc))
fun bind x f = Option.mapPartial f x
fun guard b x = if b then x else NONE
(* DEBUG: set first boolean argument to true to turn on printing. *)
@@ -516,7 +504,7 @@ fun addChecking file =
fun invalidations ((query, numArgs), dml) =
let
- val loc = ErrorMsg.dummySpan
+ val loc = dummyLoc
val optionAtomExpToExp =
fn NONE => (ENone stringTyp, loc)
| SOME e => (ESome (stringTyp,
@@ -556,16 +544,8 @@ fun invalidations ((query, numArgs), dml) =
fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) =
let
- (* ASK: does this type actually matter? It was wrong before, but things
- still seemed to work. *)
- val optionStringTyp = (TOption stringTyp, ErrorMsg.dummySpan)
val flushes = List.concat o
- map (fn (i, argss) =>
- map (fn args =>
- ffiAppCache' ("flush", i,
- map (fn arg => (arg, optionStringTyp))
- args))
- argss)
+ map (fn (i, argss) => map (fn args => ToyCache.flush (i, args)) argss)
val doExp =
fn EDml (origDmlText, failureMode) =>
let