diff options
| -rw-r--r-- | caching-tests/test.db | bin | 0 -> 5120 bytes | |||
| -rw-r--r-- | caching-tests/test.sql | 16 | ||||
| -rw-r--r-- | caching-tests/test.ur | 74 | ||||
| -rw-r--r-- | caching-tests/test.urp | 8 | ||||
| -rw-r--r-- | caching-tests/test.urs | 8 | ||||
| -rw-r--r-- | include/urweb/urweb_cpp.h | 4 | ||||
| -rw-r--r-- | src/c/urweb.c | 13 | ||||
| -rw-r--r-- | src/cjr_print.sml | 114 | ||||
| -rw-r--r-- | src/compiler.sig | 8 | ||||
| -rw-r--r-- | src/compiler.sml | 22 | ||||
| -rw-r--r-- | src/iflow.sml | 116 | ||||
| -rw-r--r-- | src/main.mlton.sml | 11 | ||||
| -rw-r--r-- | src/mono_inline.sml | 28 | ||||
| -rw-r--r-- | src/mono_util.sig | 4 | ||||
| -rw-r--r-- | src/mono_util.sml | 6 | ||||
| -rw-r--r-- | src/monoize.sig | 2 | ||||
| -rw-r--r-- | src/monoize.sml | 24 | ||||
| -rw-r--r-- | src/multimap_fn.sml | 16 | ||||
| -rw-r--r-- | src/settings.sig | 3 | ||||
| -rw-r--r-- | src/settings.sml | 4 | ||||
| -rw-r--r-- | src/sources | 14 | ||||
| -rw-r--r-- | src/sql.sig | 101 | ||||
| -rw-r--r-- | src/sql.sml | 82 | ||||
| -rw-r--r-- | src/sqlcache.sig | 6 | ||||
| -rw-r--r-- | src/sqlcache.sml | 639 | ||||
| -rw-r--r-- | src/union_find_fn.sml | 53 |
26 files changed, 1248 insertions, 128 deletions
diff --git a/caching-tests/test.db b/caching-tests/test.db Binary files differnew file mode 100644 index 00000000..a4661341 --- /dev/null +++ b/caching-tests/test.db diff --git a/caching-tests/test.sql b/caching-tests/test.sql new file mode 100644 index 00000000..7ade7278 --- /dev/null +++ b/caching-tests/test.sql @@ -0,0 +1,16 @@ +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 new file mode 100644 index 00000000..931612bc --- /dev/null +++ b/caching-tests/test.ur @@ -0,0 +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 cache01 () = + res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 43); + return <xml><body> + Reading 1. + {case res of + None => <xml>?</xml> + | 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 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")); + (* 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 new file mode 100644 index 00000000..7ac469f9 --- /dev/null +++ b/caching-tests/test.urp @@ -0,0 +1,8 @@ +database test.db +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 new file mode 100644 index 00000000..ace4ba28 --- /dev/null +++ b/caching-tests/test.urs @@ -0,0 +1,8 @@ +val cache01 : 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 cache : int -> transaction page +val flush : int -> transaction page diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index 637cddfc..be7be442 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -77,6 +77,10 @@ int uw_next_entry(struct uw_context *); void uw_write(struct uw_context *, const char*); +// For caching. +void uw_recordingStart(struct uw_context *); +char *uw_recordingRead(struct uw_context *); + uw_Basis_source uw_Basis_new_client_source(struct uw_context *, uw_Basis_string); uw_unit uw_Basis_set_client_source(struct uw_context *, uw_Basis_source, uw_Basis_string); diff --git a/src/c/urweb.c b/src/c/urweb.c index 1f2c8b3c..4cd347b2 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -477,6 +477,9 @@ struct uw_context { char *output_buffer; size_t output_buffer_size; + // For caching. + char *recording; + int remoteSock; }; @@ -561,6 +564,8 @@ uw_context uw_init(int id, uw_loggers *lg) { ctx->output_buffer = malloc(1); ctx->output_buffer_size = 1; + ctx->recording = 0; + ctx->remoteSock = -1; return ctx; @@ -1671,6 +1676,14 @@ void uw_write(uw_context ctx, const char* s) { *ctx->page.front = 0; } +void uw_recordingStart(uw_context ctx) { + ctx->recording = ctx->page.front; +} + +char *uw_recordingRead(uw_context ctx) { + return strdup(ctx->recording); +} + char *uw_Basis_attrifyInt(uw_context ctx, uw_Basis_int n) { char *result; int len; diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 0867f001..56310b81 100644 --- a/src/cjr_print.sml +++ b/src/cjr_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 @@ -734,7 +734,7 @@ fun unurlify fromClient env (t, loc) = string (Int.toString (size has_arg)), string ", ((*request)[0] == '/' ? ++*request : NULL), ", newline, - + if unboxable then unurlify' "(*request)" (#1 t) else @@ -914,7 +914,7 @@ fun unurlify fromClient env (t, loc) = space, string "4, ((*request)[0] == '/' ? ++*request : NULL), ", newline, - + string "({", newline, p_typ env (t, loc), @@ -1188,7 +1188,7 @@ fun urlify env t = string "(ctx,", space, string "it", - string (Int.toString level), + string (Int.toString level), string ");", newline] else @@ -1388,7 +1388,7 @@ fun urlify env t = string (Int.toString level), string ");", newline]) - + | _ => (ErrorMsg.errorAt loc "Unable to choose a URL encoding function"; space) in @@ -1578,7 +1578,7 @@ and p_exp' par tail env (e, loc) = newline], string "tmp;", newline, - string "})"] + string "})"] end | ENone _ => string "NULL" | ESome (t, e) => @@ -2078,7 +2078,7 @@ and p_exp' par tail env (e, loc) = space, p_exp' false false (E.pushERel (E.pushERel env "r" (TRecord rnum, loc)) - "acc" state) + "acc" state) body, string ";", newline] @@ -2102,7 +2102,7 @@ and p_exp' par tail env (e, loc) = newline, string "uw_ensure_transaction(ctx);", newline, - + case prepared of NONE => box [string "char *query = ", @@ -2187,7 +2187,7 @@ and p_exp' par tail env (e, loc) = string "uw_ensure_transaction(ctx);", newline, newline, - + #dmlPrepared (Settings.currentDbms ()) {loc = loc, id = id, dml = dml', @@ -3393,6 +3393,96 @@ fun p_file env (ds, ps) = newline, newline, + (* For sqlcache. *) + (* TODO: also record between Cache.check and Cache.store. *) + 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" + (* Starting || makes logic easier when there are no parameters. *) + val eqs = paramRepeatInit (fn p => "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 puts(\"SQLCACHE: checked ", + string i, + string ".\");\n if (cacheQuery", + string i, + (* ASK: is returning the pointer okay? Should we duplicate? *) + string " == NULL", + string eqs, + string ") {\n puts(\"miss D:\");\n uw_recordingStart(ctx);\n return NULL;\n } else {\n puts(\"hit :D\");\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: stored ", + string i, + string ".\");\n return uw_unit_v;\n };", + newline, + string "static uw_unit uw_Sqlcache_flush", + string i, + string "(uw_context ctx) {\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 };", + newline, + newline] + end) + (Sqlcache.getFfiInfo ())), + newline, p_list_sep newline (fn x => x) pds, newline, @@ -3448,7 +3538,7 @@ fun p_file env (ds, ps) = makeChecker ("uw_check_envVar", Settings.getEnvVarRules ()), newline, - + string "extern void uw_sign(const char *in, char *out);", newline, string "extern int uw_hash_blocksize;", @@ -3495,7 +3585,7 @@ fun p_file env (ds, ps) = newline, string ("uw_write_header(ctx, \"Last-Modified: " ^ Date.fmt rfcFmt nowD ^ "\\r\\n\");"), newline, - string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"), + string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"), newline, string "uw_write(ctx, jslib);", newline, @@ -3520,7 +3610,7 @@ fun p_file env (ds, ps) = newline, string ("uw_write_header(ctx, \"Content-Length: " ^ Int.toString (Word8Vector.length (#Bytes r)) ^ "\\r\\n\");"), newline, - string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"), + string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"), newline, string "uw_replace_page(ctx, \"", string (hexify (#Bytes r)), diff --git a/src/compiler.sig b/src/compiler.sig index d74ec533..c154240a 100644 --- a/src/compiler.sig +++ b/src/compiler.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 @@ -122,6 +122,7 @@ signature COMPILER = sig val pathcheck : (Mono.file, Mono.file) phase val sidecheck : (Mono.file, Mono.file) phase val sigcheck : (Mono.file, Mono.file) phase + val sqlcache : (Mono.file, Mono.file) phase val cjrize : (Mono.file, Cjr.file) phase val prepare : (Cjr.file, Cjr.file) phase val checknest : (Cjr.file, Cjr.file) phase @@ -137,12 +138,12 @@ signature COMPILER = sig val toCorify : (string, Core.file) transform val toCore_untangle : (string, Core.file) transform val toShake1 : (string, Core.file) transform - val toEspecialize1' : (string, Core.file) transform + val toEspecialize1' : (string, Core.file) transform val toShake1' : (string, Core.file) transform val toRpcify : (string, Core.file) transform val toCore_untangle2 : (string, Core.file) transform val toShake2 : (string, Core.file) transform - val toEspecialize1 : (string, Core.file) transform + val toEspecialize1 : (string, Core.file) transform val toCore_untangle3 : (string, Core.file) transform val toShake3 : (string, Core.file) transform val toTag : (string, Core.file) transform @@ -187,6 +188,7 @@ signature COMPILER = sig val toPathcheck : (string, Mono.file) transform val toSidecheck : (string, Mono.file) transform val toSigcheck : (string, Mono.file) transform + val toSqlcache : (string, Mono.file) transform val toCjrize : (string, Cjr.file) transform val toPrepare : (string, Cjr.file) transform val toChecknest : (string, Cjr.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index b46643ff..fc4067a4 100644 --- a/src/compiler.sml +++ b/src/compiler.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 @@ -25,7 +25,7 @@ * POSSIBILITY OF SUCH DAMAGE. *) -structure Compiler :> COMPILER = struct +structure Compiler :> COMPILER = struct structure UrwebLrVals = UrwebLrValsFn(structure Token = LrParser.Token) structure Lex = UrwebLexFn(structure Tokens = UrwebLrVals.Tokens) @@ -268,7 +268,7 @@ val parseUr = { | _ => absyn end handle LrParser.ParseError => [], - print = SourcePrint.p_file} + print = SourcePrint.p_file} fun p_job ({prefix, database, exe, sql, sources, debug, profile, timeout, ffi, link, headers, scripts, @@ -1100,7 +1100,7 @@ val parse = { ErrorMsg.error ("Rooted module " ^ full ^ " has multiple versions.") else (); - + makeD true "" pieces before ignore (foldl (fn (new, path) => let @@ -1455,12 +1455,22 @@ val sigcheck = { val toSigcheck = transform sigcheck "sigcheck" o toSidecheck +val sqlcache = { + 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 +} + +val toSqlcache = transform sqlcache "sqlcache" o toSigcheck + val cjrize = { func = Cjrize.cjrize, print = CjrPrint.p_file CjrEnv.empty } -val toCjrize = transform cjrize "cjrize" o toSigcheck +val toCjrize = transform cjrize "cjrize" o toSqlcache val prepare = { func = Prepare.prepare, @@ -1616,7 +1626,7 @@ fun compile job = compileC {cname = cname, oname = oname, ename = ename, libs = libs, profile = #profile job, debug = #debug job, linker = #linker job, link = #link job} - + before cleanup ()) end handle ex => (((cleanup ()) handle _ => ()); raise ex) diff --git a/src/iflow.sml b/src/iflow.sml index 40cf8993..f68d8f72 100644 --- a/src/iflow.sml +++ b/src/iflow.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 @@ -115,36 +115,36 @@ fun p_reln r es = | PCon1 s => box [string (s ^ "("), p_list p_exp es, string ")"] - | Eq => p_bop "=" es - | Ne => p_bop "<>" es - | Lt => p_bop "<" es - | Le => p_bop "<=" es - | Gt => p_bop ">" es - | Ge => p_bop ">=" es + | Cmp Eq => p_bop "=" es + | Cmp Ne => p_bop "<>" es + | Cmp Lt => p_bop "<" es + | Cmp Le => p_bop "<=" es + | Cmp Gt => p_bop ">" es + | Cmp Ge => p_bop ">=" es fun p_prop p = case p of True => string "True" | False => string "False" | Unknown => string "??" - | And (p1, p2) => box [string "(", - p_prop p1, - string ")", - space, - string "&&", - space, - string "(", - p_prop p2, - string ")"] - | Or (p1, p2) => box [string "(", - p_prop p1, - string ")", - space, - string "||", - space, - string "(", - p_prop p2, - string ")"] + | Lop (And, p1, p2) => box [string "(", + p_prop p1, + string ")", + space, + string "&&", + space, + string "(", + p_prop p2, + string ")"] + | Lop (Or, p1, p2) => box [string "(", + p_prop p1, + string ")", + space, + string "||", + space, + string "(", + p_prop p2, + string ")"] | Reln (r, es) => p_reln r es | Cond (e, p) => box [string "(", p_exp e, @@ -518,7 +518,7 @@ fun representative (db : database, e) = Variety = Nothing, Known = ref (!(#Known (unNode r))), Ge = ref NONE}) - + val r'' = ref (Node {Id = nodeId (), Rep = ref NONE, Cons = #Cons (unNode r), @@ -529,7 +529,7 @@ fun representative (db : database, e) = #Rep (unNode r) := SOME r''; r' end - | _ => raise Contradiction + | _ => raise Contradiction end in rep e @@ -687,9 +687,9 @@ fun assert (db, a) = end | _ => raise Contradiction end - | (Eq, [e1, e2]) => + | (Cmp Eq, [e1, e2]) => markEq (representative (db, e1), representative (db, e2)) - | (Ge, [e1, e2]) => + | (Cmp Ge, [e1, e2]) => let val r1 = representative (db, e1) val r2 = representative (db, e2) @@ -734,14 +734,14 @@ fun check (db, a) = (case #Variety (unNode (representative (db, e))) of Dt1 (f', _) => f' = f | _ => false) - | (Eq, [e1, e2]) => + | (Cmp Eq, [e1, e2]) => let val r1 = representative (db, e1) val r2 = representative (db, e2) in repOf r1 = repOf r2 end - | (Ge, [e1, e2]) => + | (Cmp Ge, [e1, e2]) => let val r1 = representative (db, e1) val r2 = representative (db, e2) @@ -848,7 +848,7 @@ fun setHyps (n', hs) = (hyps := (n', hs, ref false); Cc.clear db; app (fn a => Cc.assert (db, a)) hs) - end + end fun useKeys () = let @@ -872,7 +872,7 @@ fun useKeys () = let val r = Cc.check (db, - AReln (Eq, [Proj (r1, f), + AReln (Cmp Eq, [Proj (r1, f), Proj (r2, f)])) in (*Print.prefaces "Fs" @@ -888,7 +888,7 @@ fun useKeys () = r end)) ks then (changed := true; - Cc.assert (db, AReln (Eq, [r1, r2])); + Cc.assert (db, AReln (Cmp Eq, [r1, r2])); finder (hyps, acc)) else finder (hyps, a :: acc) @@ -1115,7 +1115,7 @@ fun havocCookie cname = val (_, hs, _) = !hyps in hnames := n + 1; - hyps := (n, List.filter (fn AReln (Eq, [_, Func (Other f, [])]) => f <> cname | _ => true) hs, ref false) + hyps := (n, List.filter (fn AReln (Cmp Eq, [_, Func (Other f, [])]) => f <> cname | _ => true) hs, ref false) end fun check a = Cc.check (db, a) @@ -1138,7 +1138,7 @@ fun removeDups (ls : (string * string) list) = val ls = removeDups ls in if List.exists (fn x' => x' = x) ls then - ls + ls else x :: ls end @@ -1171,7 +1171,7 @@ fun expIn rv env rvOf = | Null => inl (Func (DtCon0 "None", [])) | SqNot e => inr (case expIn e of - inl e => Reln (Eq, [e, Func (DtCon0 "Basis.bool.False", [])]) + inl e => Reln (Cmp Eq, [e, Func (DtCon0 "Basis.bool.False", [])]) | inr _ => Unknown) | Field (v, f) => inl (Proj (rvOf v, f)) | Computed _ => default () @@ -1181,15 +1181,15 @@ fun expIn rv env rvOf = val e2 = expIn e2 in inr (case (bo, e1, e2) of - (Exps f, inl e1, inl e2) => f (e1, e2) - | (Props f, v1, v2) => + (RCmp c, inl e1, inl e2) => Reln (Cmp c, [e1, e2]) + | (RLop l, v1, v2) => let fun pin v = case v of - inl e => Reln (Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) + inl e => Reln (Cmp Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) | inr p => p in - f (pin v1, pin v2) + Lop (l, pin v1, pin v2) end | _ => Unknown) end @@ -1205,7 +1205,7 @@ fun expIn rv env rvOf = (case expIn e of inl e => inl (Func (Other f, [e])) | _ => default ()) - + | Unmodeled => inl (Func (Other "allow", [rv ()])) end in @@ -1219,8 +1219,8 @@ fun decomp {Save = save, Restore = restore, Add = add} = True => (k () handle Cc.Contradiction => ()) | False => () | Unknown => () - | And (p1, p2) => go p1 (fn () => go p2 k) - | Or (p1, p2) => + | Lop (And, p1, p2) => go p1 (fn () => go p2 k) + | Lop (Or, p1, p2) => let val saved = save () in @@ -1351,7 +1351,7 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = | SOME e => let val p = case expIn e of - inl e => Reln (Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) + inl e => Reln (Cmp Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) | inr p => p val saved = #Save arg () @@ -1365,9 +1365,9 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = fun normal () = doWhere normal' in (case #Select r of - [SqExp (Binop (Exps bo, Count, SqConst (Prim.Int 0)), f)] => - (case bo (Const (Prim.Int 1), Const (Prim.Int 2)) of - Reln (Gt, [Const (Prim.Int 1), Const (Prim.Int 2)]) => + [SqExp (Binop (RCmp bo, Count, SqConst (Prim.Int 0)), f)] => + (case bo of + Gt => (case #Cont arg of SomeCol _ => () | AllCols k => @@ -1469,7 +1469,7 @@ fun evalExp env (e as (_, loc)) k = evalExp env e (fn e => doArgs (es, e :: acc)) in doArgs (es, []) - end + end in case #1 e of EPrim p => k (Const p) @@ -1519,7 +1519,7 @@ fun evalExp env (e as (_, loc)) k = ([], []) => (evalExp env' (#body rf) (fn _ => ()); St.reinstate saved; default ()) - + | (arg :: args, mode :: modes) => evalExp env arg (fn arg => let @@ -1663,7 +1663,7 @@ fun evalExp env (e as (_, loc)) k = Save = St.stash, Restore = St.reinstate, Cont = AllCols (fn x => - (St.assert [AReln (Eq, [r, x])]; + (St.assert [AReln (Cmp Eq, [r, x])]; evalExp (acc :: r :: env) b k))} q end) | EDml (e, _) => @@ -1697,15 +1697,15 @@ fun evalExp env (e as (_, loc)) k = | Delete (tab, e) => let val old = St.nextVar () - + val expIn = expIn (Var o St.nextVar) env (fn "T" => Var old | _ => raise Fail "Iflow.evalExp: Bad field expression in DELETE") val p = case expIn e of - inl e => raise Fail "Iflow.evalExp: DELETE with non-boolean" + inl e => raise Fail "Iflow.evalExp: DELETE with non-boolean" | inr p => p - + val saved = St.stash () in St.assert [AReln (Sql (tab ^ "$Old"), [Var old]), @@ -1748,7 +1748,7 @@ fun evalExp env (e as (_, loc)) k = (f, Proj (Var old, f)) :: fs) fs fs' val p = case expIn e of - inl e => raise Fail "Iflow.evalExp: UPDATE with non-boolean" + inl e => raise Fail "Iflow.evalExp: UPDATE with non-boolean" | inr p => p val saved = St.stash () in @@ -1764,7 +1764,7 @@ fun evalExp env (e as (_, loc)) k = k (Recd [])) handle Cc.Contradiction => ()) end) - + | ENextval (EPrim (Prim.String (_, seq)), _) => let val nv = St.nextVar () @@ -1780,7 +1780,7 @@ fun evalExp env (e as (_, loc)) k = val e = Var (St.nextVar ()) val e' = Func (Other ("cookie/" ^ cname), []) in - St.assert [AReln (Known, [e]), AReln (Eq, [e, e'])]; + St.assert [AReln (Known, [e]), AReln (Cmp Eq, [e, e'])]; k e end @@ -2159,7 +2159,7 @@ fun check (file : file) = end | _ => ()) end - + | _ => () in app decl (#1 file) diff --git a/src/main.mlton.sml b/src/main.mlton.sml index bfc18e59..3ae968b0 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.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 @@ -64,7 +64,7 @@ fun oneRun args = fun doArgs args = case args of [] => () - | "-version" :: rest => + | "-version" :: rest => printVersion () | "-numeric-version" :: rest => printNumericVersion () @@ -159,6 +159,9 @@ fun oneRun args = | "-iflow" :: rest => (Compiler.doIflow := true; doArgs rest) + | "-sqlcache" :: rest => + (Settings.setSqlcache true; + doArgs rest) | "-moduleOf" :: fname :: _ => (print (Compiler.moduleOf fname ^ "\n"); raise Code OS.Process.success) @@ -306,7 +309,7 @@ val () = case CommandLine.arguments () of (* Redirect the daemon's output to the socket. *) redirect Posix.FileSys.stdout; redirect Posix.FileSys.stderr; - + loop' ("", []); Socket.close sock; @@ -325,7 +328,7 @@ val () = case CommandLine.arguments () of loop () end) | ["daemon", "stop"] => - (OS.FileSys.remove socket handle OS.SysErr _ => OS.Process.exit OS.Process.success) + (OS.FileSys.remove socket handle OS.SysErr _ => OS.Process.exit OS.Process.success) | args => let val sock = UnixSock.Strm.socket () diff --git a/src/mono_inline.sml b/src/mono_inline.sml new file mode 100644 index 00000000..d23419f3 --- /dev/null +++ b/src/mono_inline.sml @@ -0,0 +1,28 @@ +structure MonoInline = struct + +fun inlineFull file = + let + val oldInline = Settings.getMonoInline () + val oldFull = !MonoReduce.fullMode + in + (Settings.setMonoInline (case Int.maxInt of + NONE => 1000000 + | SOME n => n); + MonoReduce.fullMode := true; + let + val file = MonoReduce.reduce file + val file = MonoOpt.optimize file + val file = Fuse.fuse file + val file = MonoOpt.optimize file + val file = MonoShake.shake file + in + file + end before + (MonoReduce.fullMode := oldFull; + Settings.setMonoInline oldInline)) + handle ex => (Settings.setMonoInline oldInline; + MonoReduce.fullMode := oldFull; + raise ex) + end + +end diff --git a/src/mono_util.sig b/src/mono_util.sig index da8b2e20..5c078a77 100644 --- a/src/mono_util.sig +++ b/src/mono_util.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 @@ -68,7 +68,7 @@ structure Exp : sig val fold : {typ : Mono.typ' * 'state -> 'state, exp : Mono.exp' * 'state -> 'state} -> 'state -> Mono.exp -> 'state - + val exists : {typ : Mono.typ' -> bool, exp : Mono.exp' -> bool} -> Mono.exp -> bool diff --git a/src/mono_util.sml b/src/mono_util.sml index cc531625..fd80c64f 100644 --- a/src/mono_util.sml +++ b/src/mono_util.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 @@ -281,7 +281,7 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mft t, fn t' => (ERedirect (e', t'), loc))) - + | EStrcat (e1, e2) => S.bind2 (mfe ctx e1, fn e1' => @@ -624,7 +624,7 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = (x, n, t', e', s))) in mfd - end + end fun mapfold {typ = fc, exp = fe, decl = fd} = mapfoldB {typ = fc, 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 0829abc9..2d225813 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 new file mode 100644 index 00000000..3dab68a5 --- /dev/null +++ b/src/multimap_fn.sml @@ -0,0 +1,16 @@ +functor MultimapFn (structure KeyMap : ORD_MAP structure ValSet : ORD_SET) = struct + type key = KeyMap.Key.ord_key + type item = ValSet.item + type itemSet = ValSet.set + type multimap = ValSet.set KeyMap.map + 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 = + 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 a5235357..33c01f94 100644 --- a/src/sources +++ b/src/sources @@ -168,6 +168,16 @@ $(SRC)/mono_env.sml $(SRC)/mono_print.sig $(SRC)/mono_print.sml +$(SRC)/sql.sig +$(SRC)/sql.sml + +$(SRC)/union_find_fn.sml + +$(SRC)/multimap_fn.sml + +$(SRC)/sqlcache.sig +$(SRC)/sqlcache.sml + $(SRC)/monoize.sig $(SRC)/monoize.sml @@ -186,8 +196,6 @@ $(SRC)/mono_shake.sml $(SRC)/fuse.sig $(SRC)/fuse.sml -$(SRC)/sql.sml - $(SRC)/iflow.sig $(SRC)/iflow.sml @@ -206,6 +214,8 @@ $(SRC)/sidecheck.sml $(SRC)/sigcheck.sig $(SRC)/sigcheck.sml +$(SRC)/mono_inline.sml + $(SRC)/cjr.sml $(SRC)/postgres.sig diff --git a/src/sql.sig b/src/sql.sig new file mode 100644 index 00000000..5f5d1b23 --- /dev/null +++ b/src/sql.sig @@ -0,0 +1,101 @@ +signature SQL = sig + +val debug : bool ref + +val sqlcacheMode : bool ref + +datatype chunk = + String of string + | Exp of Mono.exp + +val chunkify : Mono.exp -> chunk list + +type lvar = int + +datatype func = + DtCon0 of string + | DtCon1 of string + | UnCon of string + | Other of string + +datatype exp = + Const of Prim.t + | Var of int + | Lvar of lvar + | Func of func * exp list + | Recd of (string * exp) list + | Proj of exp * string + +datatype cmp = + Eq + | Ne + | Lt + | Le + | Gt + | Ge + +datatype reln = + Known + | Sql of string + | PCon0 of string + | PCon1 of string + | Cmp of cmp + +datatype lop = + And + | Or + +datatype prop = + True + | False + | Unknown + | Lop of lop * prop * prop + | Reln of reln * exp list + | Cond of exp * prop + +type 'a parser + +val parse : 'a parser -> Mono.exp -> 'a option + +datatype Rel = + RCmp of cmp + | RLop of lop + +datatype sqexp = + SqConst of Prim.t + | SqTrue + | SqFalse + | SqNot of sqexp + | Field of string * string + | Computed of string + | Binop of Rel * sqexp * sqexp + | SqKnown of sqexp + | Inj of Mono.exp + | SqFunc of string * sqexp + | Unmodeled + | Null + +datatype ('a,'b) sum = inl of 'a | inr of 'b + +datatype sitem = + SqField of string * string + | SqExp of sqexp * string + +type query1 = {Select : sitem list, + From : (string * string) list, + Where : sqexp option} + +datatype query = + Query1 of query1 + | Union of query * query + +val query : query parser + +datatype dml = + Insert of string * (string * sqexp) list + | Delete of string * sqexp + | Update of string * (string * sqexp) list * sqexp + +val dml : dml parser + +end diff --git a/src/sql.sml b/src/sql.sml index 91e303c3..59b4eac6 100644 --- a/src/sql.sml +++ b/src/sql.sml @@ -1,4 +1,4 @@ -structure Sql = struct +structure Sql :> SQL = struct open Mono @@ -20,24 +20,30 @@ datatype exp = | Recd of (string * exp) list | Proj of exp * string -datatype reln = - Known - | Sql of string - | PCon0 of string - | PCon1 of string - | Eq +datatype cmp = + Eq | Ne | Lt | Le | Gt | Ge +datatype reln = + Known + | Sql of string + | PCon0 of string + | PCon1 of string + | Cmp of cmp + +datatype lop = + And + | Or + datatype prop = True | False | Unknown - | And of prop * prop - | Or of prop * prop + | Lop of lop * prop * prop | Reln of reln * exp list | Cond of exp * prop @@ -177,14 +183,14 @@ val uw_ident = wrapP ident (fn s => if String.isPrefix "uw_" s andalso size s >= else NONE) -val field = wrap (follow t_ident - (follow (const ".") - uw_ident)) - (fn (t, ((), f)) => (t, f)) +val field = wrap (follow (opt (follow t_ident (const "."))) + uw_ident) + (fn (SOME (t, ()), f) => (t, f) + | (NONE, f) => ("T", f)) (* Should probably deal with this MySQL/SQLite case better some day. *) datatype Rel = - Exps of exp * exp -> prop - | Props of prop * prop -> prop + RCmp of cmp + | RLop of lop datatype sqexp = SqConst of Prim.t @@ -200,7 +206,7 @@ datatype sqexp = | Unmodeled | Null -fun cmp s r = wrap (const s) (fn () => Exps (fn (e1, e2) => Reln (r, [e1, e2]))) +fun cmp s r = wrap (const s) (fn () => RCmp r) val sqbrel = altL [cmp "=" Eq, cmp "<>" Ne, @@ -208,8 +214,8 @@ val sqbrel = altL [cmp "=" Eq, cmp "<" Lt, cmp ">=" Ge, cmp ">" Gt, - wrap (const "AND") (fn () => Props And), - wrap (const "OR") (fn () => Props Or)] + wrap (const "AND") (fn () => RLop Or), + wrap (const "OR") (fn () => RLop And)] datatype ('a, 'b) sum = inl of 'a | inr of 'b @@ -238,7 +244,7 @@ fun string chs = end else NONE - | _ => NONE + | _ => NONE val prim = altL [wrap (follow (wrapP (follow (keep Char.isDigit) (follow (const ".") (keep Char.isDigit))) @@ -267,7 +273,25 @@ fun sqlify chs = ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _), (EPrim (Prim.String (Prim.Normal, "FALSE")), _))], _), _) :: chs => SOME (e, chs) - + + | _ => NONE + +fun sqlifySqlcache chs = + case chs of + (* Could have variables as well as FFIs. *) + Exp (e as (ERel _, _)) :: chs => SOME (e, chs) + (* If it is an FFI, match the entire expression. *) + | Exp (e as (EFfiApp ("Basis", f, [(_, _)]), _)) :: chs => + if String.isPrefix "sqlify" f then + SOME (e, 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) @@ -281,6 +305,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 +318,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), @@ -317,7 +343,7 @@ fun sqexp chs = and known chs = wrap (follow known' (follow (const "(") (follow sqexp (const ")")))) (fn ((), ((), (e, ()))) => e) chs - + and func chs = wrap (follow funcName (follow (const "(") (follow sqexp (const ")")))) (fn (f, ((), (e, ()))) => (f, e)) chs @@ -396,22 +422,22 @@ val insert = log "insert" val delete = log "delete" (wrap (follow (const "DELETE FROM ") (follow uw_ident - (follow (const " AS T_T WHERE ") + (follow (follow (opt (const " AS T_T")) (const " WHERE ")) sqexp))) - (fn ((), (tab, ((), es))) => (tab, es))) + (fn ((), (tab, (_, es))) => (tab, es))) val setting = log "setting" - (wrap (follow uw_ident (follow (const " = ") sqexp)) - (fn (f, ((), e)) => (f, e))) + (wrap (follow uw_ident (follow (const " = ") sqexp)) + (fn (f, ((), e)) => (f, e))) val update = log "update" (wrap (follow (const "UPDATE ") (follow uw_ident - (follow (const " AS T_T SET ") + (follow (follow (opt (const " AS T_T")) (const " SET ")) (follow (list setting) (follow (ws (const "WHERE ")) sqexp))))) - (fn ((), (tab, ((), (fs, ((), e))))) => + (fn ((), (tab, (_, (fs, ((), e))))) => (tab, fs, e))) val dml = log "dml" diff --git a/src/sqlcache.sig b/src/sqlcache.sig new file mode 100644 index 00000000..ccc1741a --- /dev/null +++ b/src/sqlcache.sig @@ -0,0 +1,6 @@ +signature SQLCACHE = sig + +val ffiIndices : int list ref +val go : Mono.file -> Mono.file + +end diff --git a/src/sqlcache.sml b/src/sqlcache.sml new file mode 100644 index 00000000..d8169926 --- /dev/null +++ b/src/sqlcache.sml @@ -0,0 +1,639 @@ +structure Sqlcache (* :> SQLCACHE *) = struct + +open Mono + +structure IS = IntBinarySet +structure IM = IntBinaryMap +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) + +(* Filled in by [cacheWrap] during [Sqlcache]. *) +val ffiInfo : {index : int, params : int} list ref = ref [] + +fun getFfiInfo () = !ffiInfo + +(* Some FFIs have writing as their only effect, which the caching records. *) +val ffiEffectful = + (* TODO: have this less hard-coded. *) + let + val fs = SS.fromList ["htmlifyInt_w", + "htmlifyFloat_w", + "htmlifyString_w", + "htmlifyBool_w", + "htmlifyTime_w", + "attrifyInt_w", + "attrifyFloat_w", + "attrifyString_w", + "attrifyChar_w", + "urlifyInt_w", + "urlifyFloat_w", + "urlifyString_w", + "urlifyBool_w", + "urlifyChannel_w"] + in + fn (m, f) => Settings.isEffectful (m, f) + andalso not (m = "Basis" andalso SS.member (fs, f)) + end + + +(* 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 = + (* 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 + to the number of declarations in a file, Bellman-Ford style. *) + (* TODO: make incrementing of bound less janky, probably by using MonoUtil + instead of all this. *) + let + (* DEBUG: remove printing when done. *) + fun tru msg = if doPrint then (print (msg ^ "\n"); true) else true + val rec eff' = + (* ASK: is there a better way? *) + fn EPrim _ => false + (* We don't know if local functions have effects when applied. *) + | ERel idx => if inFunction andalso idx >= bound + then tru ("rel" ^ Int.toString idx) else false + | ENamed name => if IS.member (effs, name) then tru "named" else false + | ECon (_, _, NONE) => false + | ECon (_, _, SOME e) => eff e + | ENone _ => false + | ESome (_, e) => eff e + | EFfi (m, f) => if ffiEffectful (m, f) then tru "ffi" else false + | EFfiApp (m, f, _) => if ffiEffectful (m, f) then tru "ffiapp" else false + (* ASK: we're calling functions effectful if they have effects when + applied or if the function expressions themselves have effects. + Is that okay? *) + (* This is okay because the values we ultimately care about aren't + functions, and this is a conservative approximation, anyway. *) + | EApp (eFun, eArg) => effectful doPrint effs true bound eFun orelse eff eArg + | EAbs (_, _, _, e) => effectful doPrint effs inFunction (bound+1) e + | EUnop (_, e) => eff e + | EBinop (_, _, e1, e2) => eff e1 orelse eff e2 + | ERecord xs => List.exists (fn (_, e, _) => eff e) xs + | EField (e, _) => eff e + (* If any case could be effectful, consider it effectful. *) + | ECase (e, xs, _) => eff e orelse List.exists (fn (_, e) => eff e) xs + | EStrcat (e1, e2) => eff e1 orelse eff e2 + (* ASK: how should we treat these three? *) + | EError _ => tru "error" + | EReturnBlob _ => tru "blob" + | ERedirect _ => tru "redirect" + (* EWrite is a special exception because we record writes when caching. *) + | EWrite _ => false + | ESeq (e1, e2) => eff e1 orelse eff e2 + (* TODO: keep context of which local variables aren't effectful? Only + makes a difference for function expressions, though. *) + | ELet (_, _, eBind, eBody) => eff eBind orelse + effectful doPrint effs inFunction (bound+1) eBody + | EClosure (_, es) => List.exists eff es + (* TODO: deal with EQuery. *) + | EQuery _ => tru "query" + | EDml _ => tru "dml" + | ENextval _ => tru "nextval" + | ESetval _ => tru "setval" + | EUnurlify (e, _, _) => eff e + (* ASK: how should we treat this? *) + | EJavaScript _ => tru "javascript" + (* ASK: these are all effectful, right? *) + | ESignalReturn _ => tru "signalreturn" + | ESignalBind _ => tru "signalbind" + | ESignalSource _ => tru "signalsource" + | EServerCall _ => tru "servercall" + | ERecv _ => tru "recv" + | ESleep _ => tru "sleep" + | ESpawn _ => tru "spawn" + and eff = fn (e', _) => eff' e' + in + eff + end + +(* TODO: test this. *) +val effectfulMap = + let + fun doVal ((_, name, _, e, _), effMap) = + if effectful false effMap false 0 e + then IS.add (effMap, name) + else effMap + val doDecl = + fn (DVal v, effMap) => doVal (v, effMap) + (* Repeat the list of declarations a number of times equal to its size. *) + | (DValRec vs, effMap) => + List.foldl doVal effMap (List.concat (List.map (fn _ => vs) vs)) + (* ASK: any other cases? *) + | (_, effMap) => effMap + in + MonoUtil.File.fold {typ = #2, exp = #2, decl = doDecl} IS.empty + end + + +(* Boolean formula normalization. *) + +datatype normalForm = Cnf | Dnf + +datatype 'atom formula = + Atom of 'atom + | Negate of 'atom formula + | Combo of normalForm * 'atom formula list + +val flipNf = fn Cnf => Dnf | Dnf => Cnf + +fun bind xs f = List.concat (map f xs) + +val rec cartesianProduct : 'a list list -> 'a list list = + fn [] => [[]] + | (xs :: xss) => bind (cartesianProduct xss) + (fn ys => bind xs (fn x => [x :: ys])) + +(* Pushes all negation to the atoms.*) +fun pushNegate (negate : 'atom -> 'atom) (negating : bool) = + fn Atom x => Atom (if negating then negate x else x) + | Negate f => pushNegate negate (not negating) f + | Combo (n, fs) => Combo (if negating then flipNf n else n, map (pushNegate negate negating) fs) + +val rec flatten = + fn Combo (n, fs) => + Combo (n, List.foldr (fn (f, acc) => + case f of + Combo (n', fs') => if n = n' then fs' @ acc else f :: acc + | _ => f :: acc) + [] + (map flatten fs)) + | f => f + +fun normalize' (negate : 'atom -> 'atom) (norm : normalForm) = + fn Atom x => [[x]] + | Negate f => map (map negate) (normalize' negate (flipNf norm) f) + | Combo (n, fs) => + let + val fss = bind fs (normalize' negate n) + in + if n = norm then fss else cartesianProduct fss + end + +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) + +(* SQL analysis. *) + +val rec chooseTwos : 'a list -> ('a * 'a) list = + fn [] => [] + | x :: ys => map (fn y => (x, y)) ys @ chooseTwos ys + +datatype atomExp = + QueryArg of int + | DmlRel of int + | Prim of Prim.t + | Field of string * string + +val equalAtomExp = + let + val isEqual = fn EQUAL => true | _ => false + in + fn (QueryArg n1, QueryArg n2) => n1 = n2 + | (DmlRel n1, DmlRel n2) => n1 = n2 + | (Prim p1, Prim p2) => isEqual (Prim.compare (p1, p2)) + | (Field (t1, f1), Field (t2, f2)) => isEqual (String.compare (t1 ^ "." ^ f1, t2 ^ "." ^ f2)) + | _ => false + end + +structure AtomExpKey : ORD_KEY = struct + +type ord_key = atomExp + +val compare = + fn (QueryArg n1, QueryArg n2) => Int.compare (n1, n2) + | (QueryArg _, _) => LESS + | (_, QueryArg _) => GREATER + | (DmlRel n1, DmlRel n2) => Int.compare (n1, n2) + | (DmlRel _, _) => LESS + | (_, DmlRel _) => GREATER + | (Prim p1, Prim p2) => Prim.compare (p1, p2) + | (Prim _, _) => LESS + | (_, Prim _) => GREATER + | (Field (t1, f1), Field (t2, f2)) => String.compare (t1 ^ "." ^ f1, t2 ^ "." ^ f2) + +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 toKnownEquality = + (* [NONE] here means unkown. Anything that isn't a comparison between + two knowns shouldn't be used, and simply dropping unused terms is + okay in disjunctive normal form. *) + fn (Sql.Eq, SOME e1, SOME e2) => SOME (e1, e2) + | _ => NONE + val equivClasses : (Sql.cmp * atomExp option * atomExp option) list -> atomExp list list = + UF.classes + o List.foldl UF.union' UF.empty + o List.mapPartial toKnownEquality + fun addToEqs (eqs, n, e) = + case IM.find (eqs, n) of + (* Comparing to a constant seems better? *) + SOME (Prim _) => eqs + | _ => IM.insert (eqs, n, e) + val accumulateEqs = + (* [NONE] means we have a contradiction. *) + fn (_, NONE) => NONE + | ((Prim p1, Prim p2), eqso) => + (case Prim.compare (p1, p2) of + EQUAL => eqso + | _ => NONE) + | ((QueryArg n, Prim p), SOME eqs) => SOME (addToEqs (eqs, n, Prim p)) + | ((QueryArg n, DmlRel r), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r)) + | ((Prim p, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, Prim p)) + | ((DmlRel r, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r)) + (* TODO: deal with equalities involving just [DmlRel]s and [Prim]s. *) + | (_, eqso) => eqso + val eqsOfClass : atomExp list -> atomExp IM.map option = + List.foldl accumulateEqs (SOME IM.empty) + o chooseTwos + fun toAtomExps rel (cmp, e1, e2) = + let + val qa = + (* Here [NONE] means unkown. *) + fn Sql.SqConst p => SOME (Prim p) + | Sql.Field tf => SOME (Field tf) + | Sql.Inj (EPrim p, _) => SOME (Prim p) + | Sql.Inj (ERel n, _) => SOME (rel n) + (* We can't deal with anything else. *) + | _ => NONE + in + (cmp, qa e1, qa e2) + end + fun negateCmp (cmp, e1, e2) = + (case cmp of + Sql.Eq => Sql.Ne + | Sql.Ne => Sql.Eq + | Sql.Lt => Sql.Ge + | Sql.Le => Sql.Gt + | Sql.Gt => Sql.Le + | Sql.Ge => Sql.Lt, + e1, e2) + val markQuery : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula -> + (Sql.cmp * atomExp option * atomExp option) formula = + mapFormula (toAtomExps QueryArg) + val markDml : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula -> + (Sql.cmp * atomExp option * atomExp option) formula = + mapFormula (toAtomExps DmlRel) + (* No eqs should have key conflicts because no variable is in two + equivalence classes, so the [#1] can be anything. *) + val mergeEqs : (atomExp IntBinaryMap.map option list + -> atomExp IntBinaryMap.map option) = + List.foldr (fn (SOME eqs, SOME acc) => SOME (IM.unionWith #1 (eqs, acc)) | _ => NONE) + (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 *) + +val rec sqexpToFormula = + fn Sql.SqTrue => Combo (Cnf, []) + | Sql.SqFalse => Combo (Dnf, []) + | Sql.SqNot e => Negate (sqexpToFormula e) + | Sql.Binop (Sql.RCmp c, e1, e2) => Atom (c, e1, e2) + | Sql.Binop (Sql.RLop l, p1, p2) => Combo (case l of Sql.And => Cnf | Sql.Or => Dnf, + [sqexpToFormula p1, sqexpToFormula p2]) + (* ASK: any other sqexps that can be props? *) + | _ => raise Match + +fun renameTables tablePairs = + let + fun renameString table = + case List.find (fn (_, t) => table = t) tablePairs of + NONE => table + | SOME (realTable, _) => realTable + val renameSqexp = + fn Sql.Field (table, field) => Sql.Field (renameString table, field) + | e => e + fun renameAtom (cmp, e1, e2) = (cmp, renameSqexp e1, renameSqexp e2) + in + mapFormula renameAtom + end + +val rec queryToFormula = + fn Sql.Query1 {Where = NONE, ...} => Combo (Cnf, []) + | Sql.Query1 {From = tablePairs, Where = SOME e, ...} => + renameTables tablePairs (sqexpToFormula e) + | Sql.Union (q1, q2) => Combo (Dnf, [queryToFormula q1, queryToFormula q2]) + +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 + | 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 + in + renameTables [(table, "T")] + (Combo (Dnf, [f, + Combo (Cnf, [valsToFormula (table, vals), + mapFormulaSigned true update f])])) + end + +val rec tablesQuery = + fn Sql.Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs) + | Sql.Union (q1, q2) => SS.union (tablesQuery q1, tablesQuery q2) + +val tableDml = + fn Sql.Insert (tab, _) => tab + | Sql.Delete (tab, _) => tab + | Sql.Update (tab, _, _) => tab + + +(* Program instrumentation. *) + +fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), ErrorMsg.dummySpan) + +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 + +(* Always increments negative indices because that's what we need later. *) +fun incRelsBound bound inc = + MonoUtil.Exp.mapB + {typ = fn x => x, + exp = fn level => + (fn ERel n => ERel (if n >= level orelse n < 0 then n + inc else n) + | x => x), + bind = fn (level, MonoUtil.Exp.RelE _) => level + 1 | (level, _) => level} + bound + +val incRels = incRelsBound 0 + +(* 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); + (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]. *) + (* TODO: thread a [Monoize.Fm.t] through this module. *) + (ESeq ((EFfiApp ("Sqlcache", + "dummy", + [(urlifiedRel0, stringTyp)]), + loc), + (ERel 0, loc)), + loc)), + loc) + end + | _ => raise Match + in + iq + end + +fun cacheWrap (query, i, urlifiedRel0, args) = + case query of + (EQuery {state = typ, ...}, _) => + let + val () = ffiInfo := {index = i, params = length args} :: !ffiInfo + val loc = ErrorMsg.dummySpan + (* 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 rel0 = (ERel 0, loc) + in + (ECase (check, + [((PNone stringTyp, loc), + (ELet ("q", typ, query, (ESeq (store, rel0), loc)), loc)), + ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc), + (* Boolean is false because we're not unurlifying from a cookie. *) + (EUnurlify (rel0, 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 ()) + +fun addChecking file = + let + fun doExp (queryInfo as (tableToIndices, indexToQuery)) = + fn e' as ELet (v, t, + queryExp' as (EQuery {query = origQueryText, + initial, body, state, tables, exps}, 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 + (* Increment once for each new variable just made. *) + val queryExp = incRels (length newVariables) + (EQuery {query = newQueryText, + initial = initial, + body = body, + state = state, + tables = tables, + exps = exps}, + 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)) + 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. *) + fun safe bound = not o effectful true (effectfulMap file) false bound + val attempt = + (* Ziv misses Haskell's do notation.... *) + guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) ( + bind (Sql.parse Sql.query queryText) (fn queryParsed => + bind (indexOfName v) (fn index => + bind (IM.find (!urlifiedRel0s, index)) (fn urlifiedRel0 => + SOME (wrapLets (ELet (v, t, + cacheWrap (queryExp, index, urlifiedRel0, args), + incRelsBound 1 (length newVariables) letBody)), + (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index)) + tableToIndices + (tablesQuery queryParsed), + IM.insert (indexToQuery, index, (queryParsed, numArgs)))))))) + in + case attempt of + SOME pair => pair + | NONE => (e', queryInfo) + end + | ESeq ((EFfiApp ("Sqlcache", "dummy", _), _), (e', _)) => (e', queryInfo) + | e' => (e', queryInfo) + in + fileMapfold (fn exp => fn state => doExp state exp) file (SIMM.empty, IM.empty) + end + +val gunk' : (((Sql.cmp * Sql.sqexp * Sql.sqexp) formula) + * ((Sql.cmp * Sql.sqexp * Sql.sqexp) formula)) list ref = ref [] + +fun invalidations (nQueryArgs, query, dml) = + let + val loc = ErrorMsg.dummySpan + val optionAtomExpToExp = + fn NONE => (ENone stringTyp, loc) + | SOME e => (ESome (stringTyp, + (case e of + DmlRel n => ERel n + | Prim p => EPrim p + (* TODO: make new type containing only these two. *) + | _ => raise Match, + loc)), + loc) + fun eqsToInvalidation eqs = + let + fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1) + in + inv (nQueryArgs - 1) + end + (* *) + val rec madeRedundantBy : atomExp option list * atomExp option list -> bool = + fn ([], []) => true + | (NONE :: xs, _ :: ys) => madeRedundantBy (xs, ys) + | (SOME x :: xs, SOME y :: ys) => equalAtomExp (x, y) andalso madeRedundantBy (xs, ys) + | _ => false + fun removeRedundant' (xss, yss) = + case xss of + [] => yss + | xs :: xss' => + removeRedundant' (xss', + if List.exists (fn ys => madeRedundantBy (xs, ys)) (xss' @ yss) + then yss + else xs :: yss) + fun removeRedundant xss = removeRedundant' (xss, []) + val eqss = conflictMaps (queryToFormula query, dmlToFormula dml) + in + gunk' := (queryToFormula query, dmlToFormula dml) :: !gunk'; + (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)) = + let + val allIndices = SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] tableToIndices + val flushes = map (fn i => ffiAppCache' ("flush", i, [])) + val doExp = + fn dmlExp as EDml (dmlText, _) => + let + val indices = + 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 + in + sequence (flushes indices @ [dmlExp]) + end + | e' => e' + in + fileMap doExp file + end + +fun go file = + let + val () = Sql.sqlcacheMode := true + val file' = addFlushing (addChecking file) + val () = Sql.sqlcacheMode := false + in + file' + end + +end diff --git a/src/union_find_fn.sml b/src/union_find_fn.sml new file mode 100644 index 00000000..e6f8d9bf --- /dev/null +++ b/src/union_find_fn.sml @@ -0,0 +1,53 @@ +functor UnionFindFn(K : ORD_KEY) :> sig + type unionFind + val empty : unionFind + val union : unionFind * K.ord_key * K.ord_key -> unionFind + val union' : (K.ord_key * K.ord_key) * unionFind -> unionFind + val classes : unionFind -> K.ord_key list list +end = struct + +structure M = BinaryMapFn(K) +structure S = BinarySetFn(K) + +datatype entry = + Set of S.set + | Pointer of K.ord_key + +(* First map is the union-find tree, second stores equivalence classes. *) +type unionFind = entry M.map ref * S.set M.map + +val empty : unionFind = (ref M.empty, M.empty) + +fun findPair (uf, x) = + case M.find (!uf, x) of + NONE => (S.singleton x, x) + | SOME (Set set) => (set, x) + | SOME (Pointer parent) => + let + val (set, rep) = findPair (uf, parent) + in + uf := M.insert (!uf, x, Pointer rep); + (set, rep) + end + +fun find ((uf, _), x) = (S.listItems o #1 o findPair) (uf, x) + +fun classes (_, cs) = (map S.listItems o M.listItems) cs + +fun union ((uf, cs), x, y) = + let + val (xSet, xRep) = findPair (uf, x) + val (ySet, yRep) = findPair (uf, y) + val xySet = S.union (xSet, ySet) + in + (ref (M.insert (M.insert (!uf, yRep, Pointer xRep), + xRep, Set xySet)), + M.insert (case M.find (cs, yRep) of + NONE => cs + | SOME _ => #1 (M.remove (cs, yRep)), + xRep, xySet)) + end + +fun union' ((x, y), uf) = union (uf, x, y) + +end |