summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Ziv Scully <ziv@mit.edu>2015-05-06 23:11:30 -0400
committerGravatar Ziv Scully <ziv@mit.edu>2015-05-06 23:11:30 -0400
commitca3efa1458583772a9826198ed4b99eec381f2de (patch)
tree601805ceb6fea9d5d9282a2b2f51857b416e8f23
parent9c155aa780bef9e6edae2c07516693c12b37962b (diff)
More work factoring out Sqlcache back end.
-rw-r--r--src/cache.sml16
-rw-r--r--src/cjr_print.sml6
-rw-r--r--src/sources1
-rw-r--r--src/sqlcache.sig5
-rw-r--r--src/sqlcache.sml14
-rw-r--r--src/toy_cache.sml11
6 files changed, 46 insertions, 7 deletions
diff --git a/src/cache.sml b/src/cache.sml
new file mode 100644
index 00000000..8de22e0d
--- /dev/null
+++ b/src/cache.sml
@@ -0,0 +1,16 @@
+structure Cache = struct
+
+type cache =
+ {(* Takes a query ID and parameters (and, for store, the value to
+ store) and gives an FFI call that checks, stores, or flushes the
+ relevant entry. The parameters are strings for check and store and
+ optional strings for flush because some parameters might not be
+ fixed. *)
+ check : int * Mono.exp list -> Mono.exp',
+ store : int * Mono.exp list * Mono.exp -> Mono.exp',
+ flush : int * Mono.exp list -> Mono.exp',
+ (* Generates C needed for FFI calls in check, store, and flush. *)
+ setupGlobal : Print.PD.pp_desc,
+ setupQuery : {index : int, params : int} -> Print.PD.pp_desc}
+
+end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 12ad309a..e6ecedde 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -3404,7 +3404,11 @@ fun p_file env (ds, ps) =
newline,
(* For sqlcache. *)
- box (List.map ToyCache.setupQuery (Sqlcache.getFfiInfo ())),
+ let
+ val {setupGlobal, setupQuery, ...} = Sqlcache.getCache ()
+ in
+ box (setupGlobal :: newline :: List.map setupQuery (Sqlcache.getFfiInfo ()))
+ end,
newline,
p_list_sep newline (fn x => x) pds,
diff --git a/src/sources b/src/sources
index 05897cd4..aaf640ca 100644
--- a/src/sources
+++ b/src/sources
@@ -175,6 +175,7 @@ $(SRC)/union_find_fn.sml
$(SRC)/multimap_fn.sml
+$(SRC)/cache.sml
$(SRC)/toy_cache.sml
$(SRC)/sqlcache.sig
diff --git a/src/sqlcache.sig b/src/sqlcache.sig
index ccc1741a..fabc9ebf 100644
--- a/src/sqlcache.sig
+++ b/src/sqlcache.sig
@@ -1,6 +1,9 @@
signature SQLCACHE = sig
-val ffiIndices : int list ref
+val setCache : Cache.cache -> unit
+val getCache : unit -> Cache.cache
+
+val getFfiInfo : unit -> {index : int, params : int} list
val go : Mono.file -> Mono.file
end
diff --git a/src/sqlcache.sml b/src/sqlcache.sml
index 931c6737..3082904c 100644
--- a/src/sqlcache.sml
+++ b/src/sqlcache.sml
@@ -1,4 +1,4 @@
-structure Sqlcache (* :> SQLCACHE *) = struct
+structure Sqlcache :> SQLCACHE = struct
open Mono
@@ -39,6 +39,10 @@ val ffiEffectful =
andalso not (m = "Basis" andalso SS.member (fs, f))
end
+val cache = ref ToyCache.cache
+fun setCache c = cache := c
+fun getCache () = !cache
+
(* Effect analysis. *)
@@ -366,6 +370,8 @@ val tableDml =
(* Program instrumentation. *)
+val {check, store, flush, ...} = getCache ()
+
val dummyLoc = ErrorMsg.dummySpan
fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), dummyLoc)
@@ -400,8 +406,8 @@ fun cacheWrap (query, i, urlifiedRel0, resultTyp, args) =
(* We ensure before this step that all arguments aren't effectful.
by turning them into local variables as needed. *)
val argsInc = map (incRels 1) args
- val check = (ToyCache.check (i, args), dummyLoc)
- val store = (ToyCache.store (i, argsInc, urlifiedRel0), dummyLoc)
+ val check = (check (i, args), dummyLoc)
+ val store = (store (i, argsInc, urlifiedRel0), dummyLoc)
val rel0 = (ERel 0, loc)
in
ECase (check,
@@ -545,7 +551,7 @@ fun invalidations ((query, numArgs), dml) =
fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) =
let
val flushes = List.concat o
- map (fn (i, argss) => map (fn args => ToyCache.flush (i, args)) argss)
+ map (fn (i, argss) => map (fn args => flush (i, args)) argss)
val doExp =
fn EDml (origDmlText, failureMode) =>
let
diff --git a/src/toy_cache.sml b/src/toy_cache.sml
index 23dfe4fe..126768b6 100644
--- a/src/toy_cache.sml
+++ b/src/toy_cache.sml
@@ -1,4 +1,7 @@
-structure ToyCache = struct
+structure ToyCache : sig
+ val cache : Cache.cache
+end = struct
+
(* Mono *)
@@ -182,4 +185,10 @@ fun setupQuery {index, params} =
val setupGlobal = string "/* No global setup for toy cache. */"
+
+(* Bundled up. *)
+
+val cache = {check = check, store = store, flush = flush,
+ setupQuery = setupQuery, setupGlobal = setupGlobal}
+
end