aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
Diffstat
-rw-r--r--caching-tests/test.dbbin3072 -> 5120 bytes
-rw-r--r--caching-tests/test.sql7
-rw-r--r--caching-tests/test.ur74
-rw-r--r--caching-tests/test.urp1
-rw-r--r--caching-tests/test.urs2
-rw-r--r--src/cjr_print.sml70
-rw-r--r--src/compiler.sig1
-rw-r--r--src/compiler.sml6
-rw-r--r--src/monoize.sig2
-rw-r--r--src/monoize.sml24
-rw-r--r--src/multimap_fn.sml10
-rw-r--r--src/settings.sig3
-rw-r--r--src/settings.sml4
-rw-r--r--src/sources2
-rw-r--r--src/sql.sig2
-rw-r--r--src/sql.sml20
-rw-r--r--src/sqlcache.sml266
17 files changed, 411 insertions, 83 deletions
diff --git a/caching-tests/test.db b/caching-tests/test.db
index a5c91e8f..944aa851 100644
--- a/caching-tests/test.db
+++ b/caching-tests/test.db
Binary files differ
diff --git a/caching-tests/test.sql b/caching-tests/test.sql
index 862245b7..efa271ec 100644
--- a/caching-tests/test.sql
+++ b/caching-tests/test.sql
@@ -8,4 +8,9 @@ CREATE TABLE uw_Test_foo01(uw_id integer NOT NULL, uw_bar text NOT NULL,
);
- \ No newline at end of file
+ CREATE TABLE uw_Test_tab(uw_id integer NOT NULL, uw_val integer NOT NULL,
+ PRIMARY KEY (uw_id)
+
+ );
+
+ \ No newline at end of file
diff --git a/caching-tests/test.ur b/caching-tests/test.ur
index a99a387b..cb391da7 100644
--- a/caching-tests/test.ur
+++ b/caching-tests/test.ur
@@ -1,52 +1,74 @@
table foo01 : {Id : int, Bar : string} PRIMARY KEY Id
table foo10 : {Id : int, Bar : string} PRIMARY KEY Id
+table tab : {Id : int, Val : int} PRIMARY KEY Id
-fun flush01 () : transaction page =
- dml (UPDATE foo01 SET Bar = "baz01" WHERE Id = 42);
- return <xml><body>
- Flushed 1!
- </body></xml>
-
-fun flush10 () : transaction page =
- dml (UPDATE foo10 SET Bar = "baz10" WHERE Id = 42);
- return <xml><body>
- Flushed 2!
- </body></xml>
-
-fun flush11 () : transaction page =
- dml (UPDATE foo01 SET Bar = "baz11" WHERE Id = 42);
- dml (UPDATE foo10 SET Bar = "baz11" WHERE Id = 42);
- return <xml><body>
- Flushed 1 and 2!
- </body></xml>
-
-fun cache01 () : transaction page =
+fun cache01 () =
res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42);
return <xml><body>
Reading 1.
{case res of
- None => <xml></xml>
+ None => <xml>?</xml>
| Some row => <xml>{[row.Foo01.Bar]}</xml>}
</body></xml>
-fun cache10 () : transaction page =
+fun cache10 () =
res <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42);
return <xml><body>
Reading 2.
{case res of
- None => <xml></xml>
+ None => <xml>?</xml>
| Some row => <xml>{[row.Foo10.Bar]}</xml>}
</body></xml>
-fun cache11 () : transaction page =
+fun cache11 () =
res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42);
bla <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42);
return <xml><body>
Reading 1 and 2.
{case res of
- None => <xml></xml>
+ None => <xml>?</xml>
| Some row => <xml>{[row.Foo01.Bar]}</xml>}
{case bla of
- None => <xml></xml>
+ None => <xml>?</xml>
| Some row => <xml>{[row.Foo10.Bar]}</xml>}
</body></xml>
+
+fun flush01 () =
+ dml (UPDATE foo01 SET Bar = "baz01" WHERE Id = 42);
+ return <xml><body>
+ Flushed 1!
+ </body></xml>
+
+fun flush10 () =
+ dml (UPDATE foo10 SET Bar = "baz10" WHERE Id = 42);
+ return <xml><body>
+ Flushed 2!
+ </body></xml>
+
+fun flush11 () =
+ dml (UPDATE foo01 SET Bar = "baz11" WHERE Id = 42);
+ dml (UPDATE foo10 SET Bar = "baz11" WHERE Id = 42);
+ return <xml><body>
+ Flushed 1 and 2!
+ </body></xml>
+
+fun cache id =
+ res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]});
+ return <xml><body>
+ Reading {[id]}.
+ {case res of
+ None => <xml>?</xml>
+ | Some row => <xml>{[row.Tab.Val]}</xml>}
+ </body></xml>
+
+fun flush id =
+ res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]});
+ dml (case res of
+ None => (INSERT INTO tab (Id, Val) VALUES ({[id]}, 0))
+ | Some row => (UPDATE tab SET Val = {[row.Tab.Val + 1]} WHERE Id = {[id]}));
+ return <xml><body>
+ (* Flushed {[id]}! *)
+ {case res of
+ None => <xml>Initialized {[id]}!</xml>
+ | Some row => <xml>Incremented {[id]}!</xml>}
+ </body></xml>
diff --git a/caching-tests/test.urp b/caching-tests/test.urp
index 123f58e5..7ac469f9 100644
--- a/caching-tests/test.urp
+++ b/caching-tests/test.urp
@@ -3,5 +3,6 @@ sql test.sql
safeGet Test/flush01
safeGet Test/flush10
safeGet Test/flush11
+safeGet Test/flush
test
diff --git a/caching-tests/test.urs b/caching-tests/test.urs
index ce7d0350..ace4ba28 100644
--- a/caching-tests/test.urs
+++ b/caching-tests/test.urs
@@ -4,3 +4,5 @@ val cache11 : unit -> transaction page
val flush01 : unit -> transaction page
val flush10 : unit -> transaction page
val flush11 : unit -> transaction page
+val cache : int -> transaction page
+val flush : int -> transaction page
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 8ca35234..6427cf3d 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -3395,49 +3395,77 @@ fun p_file env (ds, ps) =
(* For sqlcache. *)
box (List.map
- (fn index =>
+ (fn {index, params} =>
let val i = Int.toString index
+ fun paramRepeat itemi sep =
+ let
+ val rec f =
+ fn 0 => itemi (Int.toString 0)
+ | n => f (n-1) ^ itemi (Int.toString n)
+ in
+ f (params - 1)
+ end
+ val args = paramRepeat (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 = paramRepeat (fn p => "strcmp(param" ^ i ^ "_" ^ p
+ ^ ", p" ^ p ^ ")") " || "
in box [string "static char *cache",
string i,
string " = NULL;",
newline,
- string "static uw_Basis_bool uw_Cache_check",
- string i,
- string "(uw_context ctx) { puts(\"SQLCACHE: checked ",
+ string decls,
+ newline,
+ string "static uw_Basis_string uw_Sqlcache_check",
string i,
- string ".\"); if (cache",
+ string "(uw_context ctx, ",
+ string args,
+ string ") {\n puts(\"SQLCACHE: checked ",
string i,
- string " == NULL) { uw_recordingStart(ctx); return uw_Basis_False; } else { uw_write(ctx, cache",
+ string ".\");\n if (cache",
string i,
- string "); puts(\"SQLCACHE: used ",
+ (* ASK: is returning the pointer okay? Should we duplicate? *)
+ string " == NULL || ",
+ string eqs,
+ string ") {\n puts(\"miss D:\"); puts(p0);\n return NULL;\n } else {\n puts(\"hit :D\");\n return cache",
string i,
- string ".\"); return uw_Basis_True; } };",
+ string ";\n } };",
newline,
- string "static uw_unit uw_Cache_store",
+ string "static uw_unit uw_Sqlcache_store",
string i,
- string "(uw_context ctx) { cache",
+ string "(uw_context ctx, uw_Basis_string s, ",
+ string args,
+ string ") {\n free(cache",
string i,
- string " = uw_recordingRead(ctx); puts(\"SQLCACHE: stored ",
+ string ");",
+ newline,
+ string frees,
+ newline,
+ string "cache",
string i,
- string ".\"); return uw_unit_v; };",
+ string " = strdup(s);",
+ newline,
+ string sets,
newline,
- string "static uw_unit uw_Cache_flush",
+ string "puts(\"SQLCACHE: stored ",
string i,
- string "(uw_context ctx) { free(cache",
+ string ".\"); puts(p0);\n return uw_unit_v;\n };",
+ newline,
+ string "static uw_unit uw_Sqlcache_flush",
string i,
- string "); cache",
+ string "(uw_context ctx) {\n free(cache",
string i,
- string " = NULL; puts(\"SQLCACHE: flushed ",
+ string ");\n cache",
string i,
- string ".\"); return uw_unit_v; };",
- newline,
- string "static uw_unit uw_Cache_ready",
+ string " = NULL;\n puts(\"SQLCACHE: flushed ",
string i,
- string "(uw_context ctx) { return uw_unit_v; };",
+ string ".\");\n return uw_unit_v;\n };",
newline,
newline]
end)
- (!Sqlcache.ffiIndices)),
+ (Sqlcache.getFfiInfo ())),
newline,
p_list_sep newline (fn x => x) pds,
diff --git a/src/compiler.sig b/src/compiler.sig
index fb0245ea..c154240a 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -199,7 +199,6 @@ signature COMPILER = sig
val enableBoot : unit -> unit
val doIflow : bool ref
- val doSqlcache : bool ref
val addPath : string * string -> unit
val addModuleRoot : string * string -> unit
diff --git a/src/compiler.sml b/src/compiler.sml
index d7ee8700..fc4067a4 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -83,7 +83,6 @@ type ('src, 'dst) transform = {
val debug = ref false
val dumpSource = ref false
val doIflow = ref false
-val doSqlcache = ref false
val doDumpSource = ref (fn () => ())
@@ -1457,7 +1456,10 @@ val sigcheck = {
val toSigcheck = transform sigcheck "sigcheck" o toSidecheck
val sqlcache = {
- func = (fn file => (if !doSqlcache then Sqlcache.go file else file)),
+ func = (fn file =>
+ if Settings.getSqlcache ()
+ then let val file = MonoInline.inlineFull file in Sqlcache.go file end
+ else file),
print = MonoPrint.p_file MonoEnv.empty
}
diff --git a/src/monoize.sig b/src/monoize.sig
index 838d7c4c..951db01b 100644
--- a/src/monoize.sig
+++ b/src/monoize.sig
@@ -16,7 +16,7 @@
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
diff --git a/src/monoize.sml b/src/monoize.sml
index 6073a21f..d609a67d 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1957,20 +1957,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.TFun (un, state), loc)),
loc)), loc)
- val body' = (L'.EApp (
+ val body'' = (L'.EApp (
(L'.EApp (
(L'.EApp ((L'.ERel 4, loc),
(L'.ERel 1, loc)), loc),
(L'.ERel 0, loc)), loc),
(L'.ERecord [], loc)), loc)
-
- val body = (L'.EQuery {exps = exps,
- tables = tables,
- state = state,
- query = (L'.ERel 3, loc),
- body = body',
- initial = (L'.ERel 1, loc)},
- loc)
+ val body' = (L'.EQuery {exps = exps,
+ tables = tables,
+ state = state,
+ query = (L'.ERel 3, loc),
+ body = body'',
+ initial = (L'.ERel 1, loc)},
+ loc)
+ val (body, fm) = if Settings.getSqlcache () then
+ let
+ val (urlifiedRel0, fm) = urlifyExp env fm ((L'.ERel 0, loc), state)
+ in
+ (Sqlcache.instrumentQuery (body', urlifiedRel0), fm)
+ end
+ else (body', fm)
in
((L'.EAbs ("q", s, (L'.TFun (ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc)), loc),
(L'.EAbs ("f", ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc),
diff --git a/src/multimap_fn.sml b/src/multimap_fn.sml
index 585b741f..3dab68a5 100644
--- a/src/multimap_fn.sml
+++ b/src/multimap_fn.sml
@@ -1,14 +1,16 @@
functor MultimapFn (structure KeyMap : ORD_MAP structure ValSet : ORD_SET) = struct
type key = KeyMap.Key.ord_key
type item = ValSet.item
- type items = ValSet.set
+ type itemSet = ValSet.set
type multimap = ValSet.set KeyMap.map
- fun inserts (kToVs : multimap, k : key, vs : items) : multimap =
+ val empty : multimap = KeyMap.empty
+ fun insertSet (kToVs : multimap, k : key, vs : itemSet) : multimap =
KeyMap.unionWith ValSet.union (kToVs, KeyMap.singleton (k, vs))
fun insert (kToVs : multimap, k : key, v : item) : multimap =
- inserts (kToVs, k, ValSet.singleton v)
- fun find (kToVs : multimap, k : key) =
+ insertSet (kToVs, k, ValSet.singleton v)
+ fun findSet (kToVs : multimap, k : key) =
case KeyMap.find (kToVs, k) of
SOME vs => vs
| NONE => ValSet.empty
+ val findList : multimap * key -> item list = ValSet.listItems o findSet
end
diff --git a/src/settings.sig b/src/settings.sig
index 9b32e502..e94832e0 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -279,6 +279,9 @@ signature SETTINGS = sig
val setLessSafeFfi : bool -> unit
val getLessSafeFfi : unit -> bool
+ val setSqlcache : bool -> unit
+ val getSqlcache : unit -> bool
+
val setFilePath : string -> unit
(* Sets the directory where we look for files being added below. *)
diff --git a/src/settings.sml b/src/settings.sml
index eb350c95..81c33c08 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -744,6 +744,10 @@ val less = ref false
fun setLessSafeFfi b = less := b
fun getLessSafeFfi () = !less
+val sqlcache = ref false
+fun setSqlcache b = sqlcache := b
+fun getSqlcache () = !sqlcache
+
structure SM = BinaryMapFn(struct
type ord_key = string
val compare = String.compare
diff --git a/src/sources b/src/sources
index 8860b310..518b7484 100644
--- a/src/sources
+++ b/src/sources
@@ -212,6 +212,8 @@ $(SRC)/multimap_fn.sml
$(SRC)/sqlcache.sig
$(SRC)/sqlcache.sml
+$(SRC)/mono_inline.sml
+
$(SRC)/cjr.sml
$(SRC)/postgres.sig
diff --git a/src/sql.sig b/src/sql.sig
index 2623f5e7..2aba8383 100644
--- a/src/sql.sig
+++ b/src/sql.sig
@@ -2,6 +2,8 @@ signature SQL = sig
val debug : bool ref
+val sqlcacheMode : bool ref
+
type lvar = int
datatype func =
diff --git a/src/sql.sml b/src/sql.sml
index 8d245660..d38de055 100644
--- a/src/sql.sml
+++ b/src/sql.sml
@@ -270,6 +270,22 @@ fun sqlify chs =
| _ => NONE
+fun sqlifySqlcache chs =
+ case chs of
+ (* Match entire FFI application, not just its argument. *)
+ Exp (e' as EFfiApp ("Basis", f, [(_, _)]), _) :: chs =>
+ if String.isPrefix "sqlify" f then
+ SOME ((e', ErrorMsg.dummySpan), chs)
+ else
+ NONE
+ | Exp (ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _),
+ (EPrim (Prim.String (Prim.Normal, "TRUE")), _)),
+ ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _),
+ (EPrim (Prim.String (Prim.Normal, "FALSE")), _))], _), _) :: chs =>
+ SOME (e, chs)
+
+ | _ => NONE
+
fun constK s = wrap (const s) (fn () => s)
val funcName = altL [constK "COUNT",
@@ -281,6 +297,8 @@ val funcName = altL [constK "COUNT",
val unmodeled = altL [const "COUNT(*)",
const "CURRENT_TIMESTAMP"]
+val sqlcacheMode = ref false;
+
fun sqexp chs =
log "sqexp"
(altL [wrap prim SqConst,
@@ -292,7 +310,7 @@ fun sqexp chs =
wrap known SqKnown,
wrap func SqFunc,
wrap unmodeled (fn () => Unmodeled),
- wrap sqlify Inj,
+ wrap (if !sqlcacheMode then sqlifySqlcache else sqlify) Inj,
wrap (follow (const "COALESCE(") (follow sqexp (follow (const ",")
(follow (keep (fn ch => ch <> #")")) (const ")")))))
(fn ((), (e, _)) => e),
diff --git a/src/sqlcache.sml b/src/sqlcache.sml
index b01de4c9..563b2162 100644
--- a/src/sqlcache.sml
+++ b/src/sqlcache.sml
@@ -1,21 +1,247 @@
-structure Sqlcache :> SQLCACHE = struct
+structure Sqlcache (* :> SQLCACHE *) = struct
open Sql
open Mono
structure IS = IntBinarySet
structure IM = IntBinaryMap
-structure StringKey = struct type ord_key = string val compare = String.compare end
-structure SS = BinarySetFn (StringKey)
-structure SM = BinaryMapFn (StringKey)
-structure SIMM = MultimapFn (structure KeyMap = SM structure ValSet = IS)
+structure SK = struct type ord_key = string val compare = String.compare end
+structure SS = BinarySetFn(SK)
+structure SM = BinaryMapFn(SK)
+structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS)
-val ffiIndices : int list ref = ref []
+(* Filled in by cacheWrap during Sqlcache. *)
+val ffiInfo : {index : int, params : int} list ref = ref []
-(* Expression construction utilities. *)
+fun getFfiInfo () = !ffiInfo
+
+(* Program analysis. *)
+
+val useInjIfPossible =
+ fn SqConst prim => Inj (EPrim (Prim.String (Prim.Normal, Prim.toString prim)), ErrorMsg.dummySpan)
+ | sqexp => sqexp
+
+fun equalities (canonicalTable : string -> string) :
+ sqexp -> ((string * string) * Mono.exp) list option =
+ let
+ val rec eqs =
+ fn Binop (Exps f, e1, e2) =>
+ (* TODO: use a custom datatype in Exps instead of a function. *)
+ (case f (Var 1, Var 2) of
+ Reln (Eq, [Var 1, Var 2]) =>
+ let
+ val (e1', e2') = (useInjIfPossible e1, useInjIfPossible e2)
+ in
+ case (e1', e2') of
+ (Field (t, f), Inj i) => SOME [((canonicalTable t, f), i)]
+ | (Inj i, Field (t, f)) => SOME [((canonicalTable t, f), i)]
+ | _ => NONE
+ end
+ | _ => NONE)
+ | Binop (Props f, e1, e2) =>
+ (* TODO: use a custom datatype in Props instead of a function. *)
+ (case f (True, False) of
+ And (True, False) =>
+ (case (eqs e1, eqs e2) of
+ (SOME eqs1, SOME eqs2) => SOME (eqs1 @ eqs2)
+ | _ => NONE)
+ | _ => NONE)
+ | _ => NONE
+ in
+ eqs
+ end
+
+val equalitiesQuery =
+ fn Query1 {From = tablePairs, Where = SOME exp, ...} =>
+ equalities
+ (* If we have [SELECT ... FROM T AS T' ...], use T, not T'. *)
+ (fn t =>
+ case List.find (fn (_, tAs) => t = tAs) tablePairs of
+ NONE => t
+ | SOME (tOrig, _) => tOrig)
+ exp
+ | Query1 {Where = NONE, ...} => SOME []
+ | _ => NONE
+
+val equalitiesDml =
+ fn Insert (tab, eqs) => SOME (List.mapPartial
+ (fn (name, sqexp) =>
+ case useInjIfPossible sqexp of
+ Inj e => SOME ((tab, name), e)
+ | _ => NONE)
+ eqs)
+ | Delete (tab, exp) => equalities (fn _ => tab) exp
+ (* TODO: examine the updated values and not just the way they're filtered. *)
+ (* For example, UPDATE foo SET Id = 9001 WHERE Id = 42 should update both the
+ Id = 42 and Id = 9001 cache entries. Could also think of it as doing a
+ Delete immediately followed by an Insert. *)
+ | Update (tab, _, exp) => equalities (fn _ => tab) exp
+
+val rec tablesQuery =
+ fn Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs)
+ | Union (q1, q2) => SS.union (tablesQuery q1, tablesQuery q2)
+
+val tableDml =
+ fn Insert (tab, _) => tab
+ | Delete (tab, _) => tab
+ | Update (tab, _, _) => tab
+
+
+(* Program instrumentation. *)
+
+val stringTyp = (TFfi ("Basis", "string"), ErrorMsg.dummySpan)
+
+val sequence =
+ fn (exp :: exps) =>
+ let
+ val loc = ErrorMsg.dummySpan
+ in
+ List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps
+ end
+ | _ => raise Match
+
+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
+
+val incRels = MonoUtil.Exp.map {typ = fn x => x, exp = fn ERel n => ERel (n + 1) | x => x}
+
+(* Filled in by instrumentQuery during Monoize, used during Sqlcache. *)
+val urlifiedRel0s : Mono.exp IM.map ref = ref IM.empty
+
+(* Used by Monoize. *)
+val instrumentQuery =
+ let
+ val nextQuery = ref 0
+ fun iq (query, urlifiedRel0) =
+ case query of
+ (EQuery {state = typ, ...}, loc) =>
+ let
+ val i = !nextQuery before nextQuery := !nextQuery + 1
+ in
+ urlifiedRel0s := IM.insert (!urlifiedRel0s, i, urlifiedRel0);
+ (* ASK: name variables properly? *)
+ (ELet (varPrefix ^ Int.toString i, typ, query,
+ (* Uses a dummy FFI call to keep the urlified expression around, which
+ in turn keeps the declarations required for urlification safe from
+ MonoShake. The dummy call is removed during Sqlcache. *)
+ (* ASK: is there a better way? *)
+ (ESeq ((EFfiApp ("Sqlcache", "dummy", [(urlifiedRel0, stringTyp)]), loc),
+ (ERel 0, loc)),
+ loc)),
+ loc)
+ end
+ | _ => raise Match
+ in
+ iq
+ end
+
+val gunk : ((string * string) * Mono.exp) list list ref = ref [[]]
+
+fun cacheWrap (query, i, urlifiedRel0, eqs) =
+ case query of
+ (EQuery {state = typ, ...}, _) =>
+ let
+ val loc = ErrorMsg.dummySpan
+ (* TODO: deal with effectful injected expressions. *)
+ val args = (ffiInfo := {index = i, params = length eqs} :: !ffiInfo;
+ map (fn (_, e) => (e, stringTyp)) eqs) before gunk := eqs :: !gunk
+ val argsInc = map (fn (e, t) => (incRels e, t)) args
+ in
+ (ECase (ffiAppCache ("check", i, args),
+ [((PNone stringTyp, loc),
+ (ELet ("q", typ, query,
+ (ESeq (ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argsInc),
+ (ERel 0, loc)),
+ loc)),
+ loc)),
+ ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc),
+ (* ASK: what does this bool do? *)
+ (EUnurlify ((ERel 0, loc), typ, false), loc))],
+ {disc = stringTyp, result = typ}),
+ loc)
+ end
+ | _ => raise Match
+
+fun fileMapfold doExp file start =
+ case MonoUtil.File.mapfold {typ = Search.return2,
+ exp = fn x => (fn s => Search.Continue (doExp x s)),
+ decl = Search.return2} file start of
+ Search.Continue x => x
+ | Search.Return _ => raise Match
+
+fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ())
+
+val addChecking =
+ let
+ fun doExp queryInfo =
+ fn e' as ELet (v, t, queryExp as (EQuery {query = queryText, ...}, _), body) =>
+ let
+ fun bind x f = Option.mapPartial f x
+ val attempt =
+ (* Ziv misses Haskell's do notation.... *)
+ bind (parse query queryText) (fn queryParsed =>
+ (Print.preface ("gunk> ", (MonoPrint.p_exp MonoEnv.empty queryExp));
+ bind (indexOfName v) (fn i =>
+ bind (equalitiesQuery queryParsed) (fn eqs =>
+ bind (IM.find (!urlifiedRel0s, i)) (fn urlifiedRel0 =>
+ SOME (ELet (v, t, cacheWrap (queryExp, i, urlifiedRel0, eqs), body),
+ SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, i))
+ queryInfo
+ (tablesQuery queryParsed)))))))
+ in
+ case attempt of
+ SOME pair => pair
+ | NONE => (e', queryInfo)
+ end
+ | ESeq ((EFfiApp ("Sqlcache", "dummy", _), _), (e', _)) => (e', queryInfo)
+ | e' => (e', queryInfo)
+ in
+ fn file => fileMapfold (fn exp => fn state => doExp state exp) file SIMM.empty
+ end
+
+fun addFlushing (file, queryInfo) =
+ let
+ val allIndices : int list = SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] queryInfo
+ fun flushes indices = map (fn i => ffiAppCache' ("flush", i, [])) indices
+ val doExp =
+ fn dmlExp as EDml (dmlText, _) =>
+ let
+ val indices =
+ case parse dml dmlText of
+ SOME dmlParsed => SIMM.findList (queryInfo, tableDml dmlParsed)
+ | NONE => allIndices
+ in
+ sequence (flushes indices @ [dmlExp])
+ end
+ | e' => e'
+ in
+ fileMap doExp file
+ end
+
+fun go file =
+ let
+ val () = Sql.sqlcacheMode := true
+ in
+ addFlushing (addChecking file) before Sql.sqlcacheMode := false
+ end
+
+
+(* BEGIN OLD
fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc)
fun intTyp loc = (TFfi ("Basis", "int"), loc)
+fun stringExp (s, loc) = (EPrim (Prim.String (Prim.Normal, s)), loc)
+
fun boolPat (b, loc) = (PCon (Enum,
PConFfi {mod = "Basis", datatyp = "bool", arg = NONE,
con = if b then "True" else "False"},
@@ -23,11 +249,13 @@ fun boolPat (b, loc) = (PCon (Enum,
loc)
fun boolTyp loc = (TFfi ("Basis", "int"), loc)
-fun ffiAppExp (module, func, index, loc) =
- (EFfiApp (module, func ^ Int.toString index, []), loc)
+fun ffiAppExp (module, func, index, args, loc) =
+ (EFfiApp (module, func ^ Int.toString index, args), loc)
-fun sequence ((exp :: exps), loc) =
+val sequence =
+ fn ((exp :: exps), loc) =>
List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc)) exp exps
+ | _ => raise Match
fun antiguardUnit (cond, exp, loc) =
(ECase (cond,
@@ -41,11 +269,10 @@ fun underAbs f (exp as (exp', loc)) =
EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc)
| _ => f exp
-(* Program analysis and augmentation. *)
val rec tablesRead =
- fn Query1 {From=tablePairs, ...} => SS.fromList (map #1 tablePairs)
- | Union (q1,q2) => SS.union (tablesRead q1, tablesRead q2)
+ fn Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs)
+ | Union (q1, q2) => SS.union (tablesRead q1, tablesRead q2)
val tableWritten =
fn Insert (tab, _) => tab
@@ -57,7 +284,7 @@ fun tablesInExp' exp' =
val nothing = {read = SS.empty, written = SS.empty}
in
case exp' of
- EQuery {query=e, ...} =>
+ EQuery {query = e, ...} =>
(case parse query e of
SOME q => {read = tablesRead q, written = SS.empty}
| NONE => nothing)
@@ -71,8 +298,11 @@ fun tablesInExp' exp' =
val tablesInExp =
let
fun addTables (exp', {read, written}) =
- let val {read = r, written = w} = tablesInExp' exp'
- in {read = SS.union (r, read), written = SS.union (w, written)} end
+ let
+ val {read = r, written = w} = tablesInExp' exp'
+ in
+ {read = SS.union (r, read), written = SS.union (w, written)}
+ end
in
MonoUtil.Exp.fold {typ = #2, exp = addTables}
{read = SS.empty, written = SS.empty}
@@ -150,7 +380,7 @@ fun fileFoldMapiSelected f init (file, indices) =
in
case MonoUtil.File.mapfold {typ = nada, exp = nada, decl = doDecl} file init of
Search.Continue x => x
- | _ => (file, init) (* Should never happen. *)
+ | _ => raise Match (* Should never happen. *)
end
fun fileMapSelected f = #1 o fileFoldMapiSelected (fn (_, x, _) => (f x, ())) ()
@@ -178,4 +408,6 @@ fun go file =
addCacheFlushing (fileWithChecks, tablesToIndices, writers)
end
+END OLD *)
+
end
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-18 08:02:54 +0000