diff options
| -rw-r--r-- | src/cache.sml | 16 | ||||
| -rw-r--r-- | src/cjr_print.sml | 6 | ||||
| -rw-r--r-- | src/sources | 1 | ||||
| -rw-r--r-- | src/sqlcache.sig | 5 | ||||
| -rw-r--r-- | src/sqlcache.sml | 14 | ||||
| -rw-r--r-- | src/toy_cache.sml | 11 |
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 |