summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Ziv Scully <ziv@mit.edu>2014-11-29 03:37:59 -0500
committerGravatar Ziv Scully <ziv@mit.edu>2014-11-29 03:37:59 -0500
commit476f12674420391e24afd1846e176eabe550d36c (patch)
tree005dcd53b84f29711c04508a9202f6c8e03c87c8
parentb59e6e96601c09bd97a4cce881c9b9f8bf8816a3 (diff)
Basic field-resolution invalidation.
Diffstat
-rw-r--r--caching-tests/test.dbbin5120 -> 0 bytes
-rw-r--r--caching-tests/test.sql16
-rw-r--r--caching-tests/test.ur66
-rw-r--r--caching-tests/test.urs8
-rw-r--r--src/cjr_print.sml28
-rw-r--r--src/cjrize.sml10
-rw-r--r--src/iflow.sml10
-rw-r--r--src/jscomp.sml19
-rw-r--r--src/mono.sml7
-rw-r--r--src/mono_opt.sml25
-rw-r--r--src/mono_print.sml8
-rw-r--r--src/mono_util.sml23
-rw-r--r--src/monoize.sig2
-rw-r--r--src/monoize.sml38
-rw-r--r--src/sqlcache.sml211
-rw-r--r--src/urweb.lex14
16 files changed, 266 insertions, 219 deletions
diff --git a/caching-tests/test.db b/caching-tests/test.db
deleted file mode 100644
index a4661341..00000000
--- a/caching-tests/test.db
+++ /dev/null
Binary files differ
diff --git a/caching-tests/test.sql b/caching-tests/test.sql
deleted file mode 100644
index 7ade7278..00000000
--- a/caching-tests/test.sql
+++ /dev/null
@@ -1,16 +0,0 @@
-CREATE TABLE uw_Test_foo01(uw_id int8 NOT NULL, uw_bar text NOT NULL,
- PRIMARY KEY (uw_id)
-
- );
-
- CREATE TABLE uw_Test_foo10(uw_id int8 NOT NULL, uw_bar text NOT NULL,
- PRIMARY KEY (uw_id)
-
- );
-
- CREATE TABLE uw_Test_tab(uw_id int8 NOT NULL, uw_val int8 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 931612bc..2722bcdc 100644
--- a/caching-tests/test.ur
+++ b/caching-tests/test.ur
@@ -11,26 +11,26 @@ fun cache01 () =
| Some row => <xml>{[row.Foo01.Bar]}</xml>}
</body></xml>
-fun cache10 () =
- res <- queryX (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42)
- (fn row => <xml>{[row.Foo10.Bar]}</xml>);
- return <xml><body>
- Reading 2.
- {res}
- </body></xml>
+(* fun cache10 () = *)
+(* res <- queryX (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42) *)
+(* (fn row => <xml>{[row.Foo10.Bar]}</xml>); *)
+(* return <xml><body> *)
+(* Reading 2. *)
+(* {res} *)
+(* </body></xml> *)
-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>
- | Some row => <xml>{[row.Foo01.Bar]}</xml>}
- {case bla of
- None => <xml>?</xml>
- | Some row => <xml>{[row.Foo10.Bar]}</xml>}
- </body></xml>
+(* 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> *)
+(* | Some row => <xml>{[row.Foo01.Bar]}</xml>} *)
+(* {case bla of *)
+(* None => <xml>?</xml> *)
+(* | Some row => <xml>{[row.Foo10.Bar]}</xml>} *)
+(* </body></xml> *)
fun flush01 () =
dml (INSERT INTO foo01 (Id, Bar) VALUES (42, "baz01"));
@@ -39,18 +39,18 @@ fun flush01 () =
Flushed 1!
</body></xml>
-fun flush10 () =
- dml (UPDATE foo10 SET Bar = "baz10" WHERE Id = 42);
- return <xml><body>
- Flushed 2!
- </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 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]});
@@ -63,9 +63,9 @@ fun cache id =
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]}));
+ (case res of
+ None => dml (INSERT INTO tab (Id, Val) VALUES ({[id]}, 0))
+ | Some row => dml (UPDATE tab SET Val = {[row.Tab.Val + 1]} WHERE Id = {[id]}));
return <xml><body>
(* Flushed {[id]}! *)
{case res of
diff --git a/caching-tests/test.urs b/caching-tests/test.urs
index ace4ba28..30bff733 100644
--- a/caching-tests/test.urs
+++ b/caching-tests/test.urs
@@ -1,8 +1,8 @@
val cache01 : unit -> transaction page
-val cache10 : unit -> transaction page
-val cache11 : unit -> transaction page
+(* val cache10 : unit -> transaction page *)
+(* val cache11 : unit -> transaction page *)
val flush01 : unit -> transaction page
-val flush10 : unit -> transaction page
-val flush11 : 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 56310b81..81dfefaa 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -3410,14 +3410,22 @@ fun p_file env (ds, ps) =
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 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"
- (* Starting || makes logic easier when there are no parameters. *)
+ ^ " = 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;",
@@ -3471,13 +3479,21 @@ fun p_file env (ds, ps) =
newline,
string "static uw_unit uw_Sqlcache_flush",
string i,
- string "(uw_context ctx) {\n free(cacheQuery",
+ 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: flushed ",
string i,
- string ".\");\n return uw_unit_v;\n };",
+ string ".\");}\n else { puts(\"SQLCACHE: keeping ",
+ string i,
+ string "\"); } return uw_unit_v;\n };",
newline,
newline]
end)
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 11174162..b20d6d22 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -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
@@ -431,7 +431,7 @@ fun cifyExp (eAll as (e, loc), sm) =
| L.EClosure _ => (ErrorMsg.errorAt loc "Nested closure remains in code generation";
(dummye, sm))
- | L.EQuery {exps, tables, state, query, body, initial} =>
+ | L.EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} =>
let
val (exps', sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
let
@@ -586,7 +586,7 @@ fun cifyDecl ((d, loc), sm) =
let
val (vis, sm) = ListUtil.foldlMap
(fn ((x, n, t, e, _), sm) =>
- let
+ let
val (t, sm) = cifyTyp (t, sm)
fun unravel (tAll as (t, _), eAll as (e, _)) =
@@ -601,7 +601,7 @@ fun cifyDecl ((d, loc), sm) =
(ErrorMsg.errorAt loc "Function isn't explicit at code generation";
([], tAll, eAll))
| _ => ([], tAll, eAll)
-
+
val (args, ran, e) = unravel (t, e)
val (e, sm) = cifyExp (e, sm)
in
@@ -610,7 +610,7 @@ fun cifyDecl ((d, loc), sm) =
sm vis
in
(SOME (L'.DFunRec vis, loc), NONE, sm)
- end
+ end
| L.DExport (ek, s, n, ts, t, b) =>
let
diff --git a/src/iflow.sml b/src/iflow.sml
index f68d8f72..b8346baa 100644
--- a/src/iflow.sml
+++ b/src/iflow.sml
@@ -1870,14 +1870,15 @@ val namer = MonoUtil.File.map {typ = fn t => t,
case e of
EDml (e, fm) =>
nameSubexps (fn (_, e') => (EDml (e', fm), #2 e)) e
- | EQuery {exps, tables, state, query, body, initial} =>
+ | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} =>
nameSubexps (fn (liftBy, e') =>
(EQuery {exps = exps,
tables = tables,
state = state,
query = e',
body = mliftExpInExp liftBy 2 body,
- initial = mliftExpInExp liftBy 0 initial},
+ initial = mliftExpInExp liftBy 0 initial,
+ sqlcacheInfo = sqlcacheInfo},
#2 query)) query
| _ => e,
decl = fn d => d}
@@ -2070,11 +2071,12 @@ fun check (file : file) =
| ESeq (e1, e2) => (ESeq (doExp env e1, doExp env e2), loc)
| ELet (x, t, e1, e2) => (ELet (x, t, doExp env e1, doExp (Unknown :: env) e2), loc)
| EClosure (n, es) => (EClosure (n, map (doExp env) es), loc)
- | EQuery {exps, tables, state, query, body, initial} =>
+ | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} =>
(EQuery {exps = exps, tables = tables, state = state,
query = doExp env query,
body = doExp (Unknown :: Unknown :: env) body,
- initial = doExp env initial}, loc)
+ initial = doExp env initial,
+ sqlcacheInfo = sqlcacheInfo}, loc)
| EDml (e1, mode) =>
(case parse dml e1 of
NONE => ()
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 1a476739..a4ee95f0 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -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
@@ -195,7 +195,7 @@ fun process (file : file) =
str loc "}"])],
{disc = t, result = s}), loc)
val body = (EAbs ("x", t, s, body), loc)
-
+
val st = {decls = ("jsify", n', (TFun (t, s), loc),
body, "jsify") :: #decls st,
script = #script st,
@@ -575,7 +575,7 @@ fun process (file : file) =
val e = String.translate (fn #"'" => "\\'"
| #"\\" => "\\\\"
| ch => String.str ch) e
-
+
val sc = "urfuncs[" ^ Int.toString n ^ "] = {c:\"t\",f:'"
^ e ^ "'};\n"
in
@@ -799,7 +799,7 @@ fun process (file : file) =
| _ => default ()
in
seek (e', [x])
- end
+ end
| ECase (e', pes, _) =>
let
@@ -1030,7 +1030,7 @@ fun process (file : file) =
| ERel _ => (e, st)
| ENamed _ => (e, st)
| ECon (_, _, NONE) => (e, st)
- | ECon (dk, pc, SOME e) =>
+ | ECon (dk, pc, SOME e) =>
let
val (e, st) = exp outer (e, st)
in
@@ -1082,7 +1082,7 @@ fun process (file : file) =
in
((EBinop (bi, s, e1, e2), loc), st)
end
-
+
| ERecord xets =>
let
val (xets, st) = ListUtil.foldlMap (fn ((x, e, t), st) =>
@@ -1176,7 +1176,7 @@ fun process (file : file) =
((EClosure (n, es), loc), st)
end
- | EQuery {exps, tables, state, query, body, initial} =>
+ | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} =>
let
val row = exps @ map (fn (x, xts) => (x, (TRecord xts, loc))) tables
val row = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row
@@ -1187,7 +1187,8 @@ fun process (file : file) =
val (initial, st) = exp outer (initial, st)
in
((EQuery {exps = exps, tables = tables, state = state,
- query = query, body = body, initial = initial}, loc), st)
+ query = query, body = body, initial = initial,
+ sqlcacheInfo = sqlcacheInfo}, loc), st)
end
| EDml (e, mode) =>
let
@@ -1257,7 +1258,7 @@ fun process (file : file) =
in
((ESignalSource e, loc), st)
end
-
+
| EServerCall (e1, t, ef, fm) =>
let
val (e1, st) = exp outer (e1, st)
diff --git a/src/mono.sml b/src/mono.sml
index 1e402e57..5185e48c 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -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
@@ -107,7 +107,8 @@ datatype exp' =
state : typ,
query : exp, (* exp of string type containing sql query *)
body : exp,
- initial : exp }
+ initial : exp,
+ sqlcacheInfo : exp }
| EDml of exp * failure_mode
| ENextval of exp
| ESetval of exp * exp
@@ -119,7 +120,7 @@ datatype exp' =
| ESignalReturn of exp
| ESignalBind of exp * exp
| ESignalSource of exp
-
+
| EServerCall of exp * typ * effect * failure_mode
| ERecv of exp * typ
| ESleep of exp
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index d1e5ce55..97f78d3d 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -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
@@ -166,7 +166,7 @@ fun exp e =
e
| EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => exp (EStrcat (e1, e2))
-
+
| EStrcat ((EPrim (Prim.String (Prim.Html, s1)), loc), (EPrim (Prim.String (Prim.Html, s2)), _)) =>
let
val s =
@@ -179,7 +179,7 @@ fun exp e =
in
EPrim (Prim.String (Prim.Html, s))
end
-
+
| EStrcat ((EPrim (Prim.String (_, s1)), loc), (EPrim (Prim.String (_, s2)), _)) =>
EPrim (Prim.String (Prim.Normal, s1 ^ s2))
@@ -397,18 +397,20 @@ fun exp e =
initial = (EPrim (Prim.String (k, "")), _),
body = (EStrcat ((EPrim (Prim.String (_, s)), _),
(EStrcat ((ERel 0, _),
- e'), _)), _)}, loc) =>
+ e'), _)), _),
+ sqlcacheInfo}, loc) =>
if (case k of Prim.Normal => s = "" | Prim.Html => CharVector.all Char.isSpace s) then
EQuery {exps = exps, tables = tables, query = query,
state = (TRecord [], loc),
initial = (ERecord [], loc),
- body = (optExp (EWrite e', loc), loc)}
+ body = (optExp (EWrite e', loc), loc),
+ sqlcacheInfo = Monoize.urlifiedUnit}
else
e
| EWrite (EQuery {exps, tables, state, query,
initial = (EPrim (Prim.String (_, "")), _),
- body}, loc) =>
+ body, sqlcacheInfo}, loc) =>
let
fun passLets (depth, (e', _), lets) =
case e' of
@@ -423,7 +425,8 @@ fun exp e =
EQuery {exps = exps, tables = tables, query = query,
state = (TRecord [], loc),
initial = (ERecord [], loc),
- body = body}
+ body = body,
+ sqlcacheInfo = Monoize.urlifiedUnit}
end
else
e
@@ -532,7 +535,7 @@ fun exp e =
else
ENone (TFfi ("Basis", "string"), loc))
- | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String (_, s)), loc), _)]) =>
+ | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String (_, s)), loc), _)]) =>
let
fun uwify (cs, acc) =
case cs of
@@ -560,7 +563,7 @@ fun exp e =
EPrim (Prim.String (Prim.Normal, s))
end
- | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String (_, s)), loc), _)]) =>
+ | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String (_, s)), loc), _)]) =>
let
fun uwify (cs, acc) =
case cs of
@@ -585,7 +588,7 @@ fun exp e =
EPrim (Prim.String (Prim.Normal, s))
end
- | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String (_, s)), _), _)]) =>
+ | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String (_, s)), _), _)]) =>
EPrim (Prim.String (Prim.Normal, unAs s))
| EFfiApp ("Basis", "unAs", [(e', _)]) =>
let
@@ -620,7 +623,7 @@ fun exp e =
EFfiApp ("Basis", "attrifyChar_w", [e])
| EBinop (_, "+", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.+ (n1, n2)))
-
+
| _ => e
and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
diff --git a/src/mono_print.sml b/src/mono_print.sml
index c81b362a..0ff51f37 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -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
@@ -310,7 +310,7 @@ fun p_exp' par env (e, _) =
p_exp env e]) es,
string ")"]
- | EQuery {exps, tables, state, query, body, initial} =>
+ | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} =>
box [string "query[",
p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) exps,
string "] [",
@@ -391,7 +391,7 @@ fun p_vali env (x, n, t, e, s) =
string "__",
string (Int.toString n)]
else
- string x
+ string x
in
box [xp,
space,
@@ -541,7 +541,7 @@ fun p_decl env (dAll as (d, _) : decl) =
space,
p_policy env p]
| DOnError _ => string "ONERROR"
-
+
fun p_file env (file, _) =
let
val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
diff --git a/src/mono_util.sml b/src/mono_util.sml
index fd80c64f..ba10ad32 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -314,7 +314,7 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
fn es' =>
(EClosure (n, es'), loc))
- | EQuery {exps, tables, state, query, body, initial} =>
+ | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} =>
S.bind2 (ListUtil.mapfold (fn (x, t) =>
S.map2 (mft t,
fn t' => (x, t'))) exps,
@@ -334,15 +334,20 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
RelE ("acc", dummyt)))
body,
fn body' =>
- S.map2 (mfe ctx initial,
+ (* ASK: is this the right thing to do? *)
+ S.bind2 (mfe ctx initial,
fn initial' =>
- (EQuery {exps = exps',
- tables = tables',
- state = state',
- query = query',
- body = body',
- initial = initial'},
- loc)))))))
+ S.map2 (mfe (bind (ctx, RelE ("queryResult", dummyt)))
+ sqlcacheInfo,
+ fn sqlcacheInfo' =>
+ (EQuery {exps = exps',
+ tables = tables',
+ state = state',
+ query = query',
+ body = body',
+ initial = initial',
+ sqlcacheInfo = sqlcacheInfo},
+ loc))))))))
| EDml (e, fm) =>
S.map2 (mfe ctx e,
diff --git a/src/monoize.sig b/src/monoize.sig
index 951db01b..549bf6ee 100644
--- a/src/monoize.sig
+++ b/src/monoize.sig
@@ -31,4 +31,6 @@ signature MONOIZE = sig
val liftExpInExp : int -> Mono.exp -> Mono.exp
+ val urlifiedUnit : Mono.exp
+
end
diff --git a/src/monoize.sml b/src/monoize.sml
index 2d225813..5c314c54 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -681,6 +681,16 @@ fun fooifyExp fk env =
val attrifyExp = fooifyExp Attr
val urlifyExp = fooifyExp Url
+val urlifiedUnit =
+ let
+ val loc = ErrorMsg.dummySpan
+ (* Urlifies [ERel 0] to match the [sqlcacheInfo] field of [EQuery]s. *)
+ val (urlified, _) = urlifyExp CoreEnv.empty (Fm.empty 0)
+ ((L'.ERel 0, loc), (L'.TRecord [], loc))
+ in
+ urlified
+ end
+
datatype 'a failable_search =
Found of 'a
| NotFound
@@ -1957,26 +1967,24 @@ 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, 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)
+ val (urlifiedRel0, fm) = urlifyExp env fm ((L'.ERel 0, loc), state)
+ val body = (L'.EQuery {exps = exps,
+ tables = tables,
+ state = state,
+ query = (L'.ERel 3, loc),
+ body = body',
+ initial = (L'.ERel 1, loc),
+ sqlcacheInfo = urlifiedRel0},
+ loc)
+ val body = if Settings.getSqlcache ()
+ then Sqlcache.instrumentQuery (body, urlifiedRel0)
+ else body
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/sqlcache.sml b/src/sqlcache.sml
index d8169926..b555ca7a 100644
--- a/src/sqlcache.sml
+++ b/src/sqlcache.sml
@@ -176,12 +176,10 @@ fun normalize' (negate : 'atom -> 'atom) (norm : normalForm) =
fun normalize negate norm = normalize' negate norm o flatten o pushNegate negate false
-fun mapFormulaSigned positive mf =
- fn Atom x => Atom (mf (positive, x))
- | Negate f => Negate (mapFormulaSigned (not positive) mf f)
- | Combo (n, fs) => Combo (n, map (mapFormulaSigned positive mf) fs)
-
-fun mapFormula mf = mapFormulaSigned true (fn (_, x) => mf x)
+fun mapFormula mf =
+ fn Atom x => Atom (mf x)
+ | Negate f => Negate (mapFormula mf f)
+ | Combo (n, fs) => Combo (n, map (mapFormula mf) fs)
(* SQL analysis. *)
@@ -225,11 +223,10 @@ val compare =
end
structure UF = UnionFindFn(AtomExpKey)
-
-(* val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula *)
-(* * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula *)
-(* -> Mono.exp' IM.map list = *)
-(* let *)
+val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula
+ * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula
+ -> atomExp IM.map list =
+ let
val toKnownEquality =
(* [NONE] here means unkown. Anything that isn't a comparison between
two knowns shouldn't be used, and simply dropping unused terms is
@@ -297,12 +294,12 @@ structure UF = UnionFindFn(AtomExpKey)
(SOME IM.empty)
fun dnf (fQuery, fDml) =
normalize negateCmp Dnf (Combo (Cnf, [markQuery fQuery, markDml fDml]))
- (* in *)
- val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula
- * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula
- -> atomExp IM.map list =
- List.mapPartial (mergeEqs o map eqsOfClass o equivClasses) o dnf
- (* end *)
+ in
+ (* val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula *)
+ (* * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula *)
+ (* -> atomExp IM.map list = *)
+ List.mapPartial (mergeEqs o map eqsOfClass o equivClasses) o dnf
+ end
val rec sqexpToFormula =
fn Sql.SqTrue => Combo (Cnf, [])
@@ -338,32 +335,21 @@ fun valsToFormula (table, vals) =
Combo (Cnf, map (fn (field, v) => Atom (Sql.Eq, Sql.Field (table, field), v)) vals)
val rec dmlToFormula =
- fn Sql.Insert tableVals => valsToFormula tableVals
+ fn Sql.Insert (table, vals) => valsToFormula (table, vals)
| Sql.Delete (table, wher) => renameTables [(table, "T")] (sqexpToFormula wher)
- (* TODO: refine formula for the vals part, which could take into account the wher part. *)
- (* TODO: use pushNegate instead of mapFormulaSigned? *)
| Sql.Update (table, vals, wher) =>
let
- val f = sqexpToFormula wher
- fun update (positive, a) =
- let
- fun updateIfNecessary field =
- case List.find (fn (f, _) => field = f) vals of
- SOME (_, v) => (if positive then Sql.Eq else Sql.Ne,
- Sql.Field (table, field),
- v)
- | NONE => a
- in
- case a of
- (_, Sql.Field (_, field), _) => updateIfNecessary field
- | (_, _, Sql.Field (_, field)) => updateIfNecessary field
- | _ => a
- end
+ val fWhere = sqexpToFormula wher
+ val fVals = valsToFormula (table, vals)
+ (* TODO: don't use field name hack. *)
+ val markField =
+ fn Sql.Field (t, v) => Sql.Field (t, v ^ "*")
+ | e => e
+ val mark = mapFormula (fn (cmp, e1, e2) => (cmp, markField e1, markField e2))
in
renameTables [(table, "T")]
- (Combo (Dnf, [f,
- Combo (Cnf, [valsToFormula (table, vals),
- mapFormulaSigned true update f])]))
+ (Combo (Dnf, [Combo (Cnf, [fVals, mark fWhere]),
+ Combo (Cnf, [mark fVals, fWhere])]))
end
val rec tablesQuery =
@@ -482,54 +468,62 @@ fun fileMapfold doExp file start =
fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ())
+fun factorOutNontrivial text =
+ let
+ val loc = ErrorMsg.dummySpan
+ fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
+ val chunks = Sql.chunkify text
+ val (newText, newVariables) =
+ (* Important that this is foldr (to oppose foldl below). *)
+ List.foldr
+ (fn (chunk, (qText, newVars)) =>
+ (* Variable bound to the head of newBs will have the lowest index. *)
+ case chunk of
+ Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
+ | Sql.Exp e =>
+ let
+ val n = length newVars
+ in
+ (* This is the (n + 1)th new variable, so there are
+ already n new variables bound, so we increment
+ indices by n. *)
+ (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
+ end
+ | Sql.String s => (strcat (stringExp s, qText), newVars))
+ (stringExp "", [])
+ chunks
+ fun wrapLets e' =
+ (* Important that this is foldl (to oppose foldr above). *)
+ List.foldl (fn (v, e') => ELet ("sqlArgz", stringTyp, v, (e', loc)))
+ e'
+ newVariables
+ val numArgs = length newVariables
+ in
+ (newText, wrapLets, numArgs)
+ end
+
fun addChecking file =
let
- fun doExp (queryInfo as (tableToIndices, indexToQuery)) =
+ fun doExp (queryInfo as (tableToIndices, indexToQueryNumArgs)) =
fn e' as ELet (v, t,
- queryExp' as (EQuery {query = origQueryText,
- initial, body, state, tables, exps}, queryLoc),
+ (EQuery {query = origQueryText,
+ initial, body, state, tables, exps, sqlcacheInfo}, queryLoc),
letBody) =>
let
- val loc = ErrorMsg.dummySpan
- val chunks = Sql.chunkify origQueryText
- fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
- val (newQueryText, newVariables) =
- (* Important that this is foldr (to oppose foldl below). *)
- List.foldr
- (fn (chunk, (qText, newVars)) =>
- (* Variable bound to the head of newBs will have the lowest index. *)
- case chunk of
- Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
- | Sql.Exp e =>
- let
- val n = length newVars
- in
- (* This is the (n + 1)th new variable, so
- there are already n new variables bound,
- so we increment indices by n. *)
- (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
- end
- | Sql.String s => (strcat (stringExp s, qText), newVars))
- (stringExp "", [])
- chunks
- fun wrapLets e' =
- (* Important that this is foldl (to oppose foldr above). *)
- List.foldl (fn (v, e') => ELet ("sqlArgz", stringTyp, v, (e', loc)))
- e'
- newVariables
- val numArgs = length newVariables
+ val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText
(* Increment once for each new variable just made. *)
- val queryExp = incRels (length newVariables)
+ val queryExp = incRels numArgs
(EQuery {query = newQueryText,
initial = initial,
body = body,
state = state,
tables = tables,
- exps = exps},
+ exps = exps,
+ sqlcacheInfo = sqlcacheInfo},
queryLoc)
val (EQuery {query = queryText, ...}, _) = queryExp
- val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText));
- val args = List.tabulate (numArgs, fn n => (ERel n, loc))
+ val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText))
+ val args = List.tabulate (numArgs, fn n => (ERel n, ErrorMsg.dummySpan))
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. *)
@@ -542,11 +536,11 @@ fun addChecking file =
bind (IM.find (!urlifiedRel0s, index)) (fn urlifiedRel0 =>
SOME (wrapLets (ELet (v, t,
cacheWrap (queryExp, index, urlifiedRel0, args),
- incRelsBound 1 (length newVariables) letBody)),
+ incRelsBound 1 numArgs letBody)),
(SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
tableToIndices
(tablesQuery queryParsed),
- IM.insert (indexToQuery, index, (queryParsed, numArgs))))))))
+ IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs))))))))
in
case attempt of
SOME pair => pair
@@ -558,10 +552,12 @@ fun addChecking file =
fileMapfold (fn exp => fn state => doExp state exp) file (SIMM.empty, IM.empty)
end
+val gunk : (Sql.query * Sql.dml * Mono.exp list list) list ref = ref []
+
val gunk' : (((Sql.cmp * Sql.sqexp * Sql.sqexp) formula)
* ((Sql.cmp * Sql.sqexp * Sql.sqexp) formula)) list ref = ref []
-fun invalidations (nQueryArgs, query, dml) =
+fun invalidations ((query, numArgs), dml) =
let
val loc = ErrorMsg.dummySpan
val optionAtomExpToExp =
@@ -578,9 +574,10 @@ fun invalidations (nQueryArgs, query, dml) =
let
fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1)
in
- inv (nQueryArgs - 1)
+ inv (numArgs - 1)
end
- (* *)
+ (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here
+ represents unknown, which means a wider invalidation. *)
val rec madeRedundantBy : atomExp option list * atomExp option list -> bool =
fn ([], []) => true
| (NONE :: xs, _ :: ys) => madeRedundantBy (xs, ys)
@@ -601,39 +598,67 @@ fun invalidations (nQueryArgs, query, dml) =
(map (map optionAtomExpToExp) o removeRedundant o map eqsToInvalidation) eqss
end
-val gunk : Mono.exp list list list ref = ref []
-fun addFlushing (file, queryInfo as (tableToIndices, indexToQuery)) =
+(* gunk := (queryParsed, dmlParsed, invalidations (numArgs, queryParsed, dmlParsed)) :: !gunk); *)
+
+fun addFlushing (file, (tableToIndices, indexToQueryNumArgs)) =
let
- val allIndices = SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] tableToIndices
- val flushes = map (fn i => ffiAppCache' ("flush", i, []))
+ (* TODO: write this. *)
+ val allInvs = () (* SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] tableToIndices *)
+ val flushes = List.concat o
+ map (fn (i, argss) =>
+ map (fn args =>
+ ffiAppCache' ("flush", i,
+ map (fn arg => (arg, stringTyp)) args)) argss)
val doExp =
- fn dmlExp as EDml (dmlText, _) =>
+ fn EDml (origDmlText, failureMode) =>
let
- val indices =
+ val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText
+ val dmlText = incRels numArgs newDmlText
+ val dmlExp = EDml (dmlText, failureMode)
+ val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty dmlText))
+ val invs =
case Sql.parse Sql.dml dmlText of
SOME dmlParsed =>
- map (fn i => ((case IM.find (indexToQuery, i) of
- NONE => ()
- | SOME (queryParsed, numArgs) =>
- gunk := invalidations (numArgs, queryParsed, dmlParsed) :: !gunk);
- i)) (SIMM.findList (tableToIndices, tableDml dmlParsed))
- | NONE => allIndices
+ map (fn i => (case IM.find (indexToQueryNumArgs, i) of
+ SOME queryNumArgs =>
+ (i, invalidations (queryNumArgs, dmlParsed))
+ (* TODO: fail more gracefully. *)
+ | NONE => raise Match))
+ (SIMM.findList (tableToIndices, tableDml dmlParsed))
+ (* TODO: fail more gracefully. *)
+ | NONE => raise Match
in
- sequence (flushes indices @ [dmlExp])
+ wrapLets (sequence (flushes invs @ [dmlExp]))
end
| e' => e'
in
fileMap doExp file
end
+val inlineSql =
+ let
+ val doExp =
+ (* TODO: EQuery, too? *)
+ (* ASK: should this live in [MonoOpt]? *)
+ fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) =>
+ let
+ val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases
+ in
+ ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)})
+ end
+ | e => e
+ in
+ fileMap doExp
+ end
+
fun go file =
let
val () = Sql.sqlcacheMode := true
- val file' = addFlushing (addChecking file)
+ val file' = addFlushing (addChecking (inlineSql file))
val () = Sql.sqlcacheMode := false
in
- file'
+ file'
end
end
diff --git a/src/urweb.lex b/src/urweb.lex
index 0d316ed2..785f7a81 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -18,7 +18,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
@@ -50,7 +50,7 @@ in
else
();
commentLevel := !commentLevel + 1)
-
+
fun exitComment () =
(ignore (commentLevel := !commentLevel - 1);
if !commentLevel = 0 then
@@ -58,15 +58,15 @@ in
else
())
- fun eof () =
- let
+ fun eof () =
+ let
val pos = ErrorMsg.lastLineStart ()
in
if !commentLevel > 0 then
ErrorMsg.errorAt' (!commentPos, !commentPos) "Unterminated comment"
else
();
- Tokens.EOF (pos, pos)
+ Tokens.EOF (pos, pos)
end
end
@@ -177,7 +177,7 @@ fun unescape loc s =
%s COMMENT STRING CHAR XML XMLTAG;
id = [a-z_][A-Za-z0-9_']*;
-xmlid = [A-Za-z][A-Za-z0-9-_]*;
+xmlid = [A-Za-z][A-Za-z0-9_-]*;
cid = [A-Z][A-Za-z0-9_]*;
ws = [\ \t\012\r];
intconst = [0-9]+;
@@ -300,7 +300,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
Tokens.XML_END (yypos, yypos + size yytext))
else
Tokens.END_TAG (id, yypos, yypos + size yytext)
- | _ =>
+ | _ =>
Tokens.END_TAG (id, yypos, yypos + size yytext)
end);
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-15 18:29:00 +0000