From 0e1252d5a6330570df698df924a0554b688042e8 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Sat, 8 Mar 2014 05:06:22 -0500 Subject: Identifies tables read or touched by queries. --- src/compiler.sml | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) (limited to 'src/compiler.sml') diff --git a/src/compiler.sml b/src/compiler.sml index cc4e33c5..36a1b03f 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, @@ -1090,7 +1090,7 @@ val parse = { ErrorMsg.error ("Rooted module " ^ full ^ " has multiple versions.") else (); - + makeD true "" pieces before ignore (foldl (fn (new, path) => let @@ -1438,12 +1438,19 @@ val sigcheck = { val toSigcheck = transform sigcheck "sigcheck" o toSidecheck +val sqlcache = { + func = (fn file => (Sql.go file; 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, @@ -1596,7 +1603,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) -- cgit v1.2.3 From 93d6de491838eb3607a12686bfdc250366aa60e4 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Tue, 25 Mar 2014 02:04:06 -0400 Subject: ML half of initial prototype. (Doesn't compile because there's no C yet.) --- caching-tests/test.ur | 81 ++++++++++++++++++++++ caching-tests/test.urp | 6 ++ caching-tests/test.urs | 6 ++ src/compiler.sig | 4 +- src/compiler.sml | 8 +-- src/multimap_fn.sml | 14 ++++ src/sql.sig | 79 ++++++++++++++++++++++ src/sql.sml | 79 +--------------------- src/sql_cache.sml | 179 +++++++++++++++++++++++++++++++++++++++++++++++++ 9 files changed, 372 insertions(+), 84 deletions(-) create mode 100644 caching-tests/test.ur create mode 100644 caching-tests/test.urp create mode 100644 caching-tests/test.urs create mode 100644 src/multimap_fn.sml create mode 100644 src/sql.sig create mode 100644 src/sql_cache.sml (limited to 'src/compiler.sml') diff --git a/caching-tests/test.ur b/caching-tests/test.ur new file mode 100644 index 00000000..4703e229 --- /dev/null +++ b/caching-tests/test.ur @@ -0,0 +1,81 @@ +table foo01 : {Id : int, Bar : string} PRIMARY KEY Id +table foo10 : {Id : int, Bar : string} PRIMARY KEY Id + +(* val query = (SELECT * FROM foo WHERE foo.Bar = "baz") *) +(* val insert = (INSERT INTO foo (Id, Bar) VALUES (42, "baz")) *) + +fun flush01 () : transaction page= + dml (INSERT INTO foo01 (Id, Bar) VALUES (42, "baz")); + return + + + Flushed 1! + + + +fun flush10 () : transaction page= + dml (INSERT INTO foo10 (Id, Bar) VALUES (42, "baz")); + return + + + Flushed 2! + + + +fun flush11 () : transaction page= + dml (INSERT INTO foo01 (Id, Bar) VALUES (42, "baz")); + dml (INSERT INTO foo10 (Id, Bar) VALUES (42, "baz")); + return + + + Flushed 1 and 2! + + + +fun cache01 () : transaction page = + res <- oneOrNoRows (SELECT foo01.Id, foo01.Bar + FROM foo01 + WHERE foo01.Bar = "baz"); + return + + + Reading 1. + {case res of + None => + | Some row => {[row.Foo01.Bar]}} + + + +fun cache10 () : transaction page = + res <- oneOrNoRows (SELECT foo10.Id, foo10.Bar + FROM foo10 + WHERE foo10.Bar = "baz"); + return + + + Reading 2. + {case res of + None => + | Some row => {[row.Foo10.Bar]}} + + + +fun cache11 () : transaction page = + res <- oneOrNoRows (SELECT foo01.Id, foo01.Bar + FROM foo01 + WHERE foo01.Bar = "baz"); + bla <- oneOrNoRows (SELECT foo10.Id, foo10.Bar + FROM foo10 + WHERE foo10.Bar = "baz"); + return + + + Reading 1 and 2. + {case res of + None => + | Some row => {[row.Foo01.Bar]}} + {case bla of + None => + | Some row => {[row.Foo10.Bar]}} + + diff --git a/caching-tests/test.urp b/caching-tests/test.urp new file mode 100644 index 00000000..e5111220 --- /dev/null +++ b/caching-tests/test.urp @@ -0,0 +1,6 @@ +database dbname=test +safeGet Test/flush01 +safeGet Test/flush10 +safeGet Test/flush11 + +test diff --git a/caching-tests/test.urs b/caching-tests/test.urs new file mode 100644 index 00000000..ce7d0350 --- /dev/null +++ b/caching-tests/test.urs @@ -0,0 +1,6 @@ +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 diff --git a/src/compiler.sig b/src/compiler.sig index df567441..a0a653a7 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -122,7 +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 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 @@ -187,7 +187,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 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 36a1b03f..de10d8c8 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1438,19 +1438,19 @@ val sigcheck = { val toSigcheck = transform sigcheck "sigcheck" o toSidecheck -val sqlcache = { - func = (fn file => (Sql.go file; file)), +val sqlCache = { + func = SqlCache.go, print = MonoPrint.p_file MonoEnv.empty } -val toSqlcache = transform sqlcache "sqlcache" o toSigcheck +val toSqlCache = transform sqlCache "sqlCache" o toSigcheck val cjrize = { func = Cjrize.cjrize, print = CjrPrint.p_file CjrEnv.empty } -val toCjrize = transform cjrize "cjrize" o toSqlcache +val toCjrize = transform cjrize "cjrize" o toSqlCache val prepare = { func = Prepare.prepare, diff --git a/src/multimap_fn.sml b/src/multimap_fn.sml new file mode 100644 index 00000000..585b741f --- /dev/null +++ b/src/multimap_fn.sml @@ -0,0 +1,14 @@ +functor MultimapFn (structure KeyMap : ORD_MAP structure ValSet : ORD_SET) = struct + type key = KeyMap.Key.ord_key + type item = ValSet.item + type items = ValSet.set + type multimap = ValSet.set KeyMap.map + fun inserts (kToVs : multimap, k : key, vs : items) : multimap = + KeyMap.unionWith ValSet.union (kToVs, KeyMap.singleton (k, vs)) + fun insert (kToVs : multimap, k : key, v : item) : multimap = + inserts (kToVs, k, ValSet.singleton v) + fun find (kToVs : multimap, k : key) = + case KeyMap.find (kToVs, k) of + SOME vs => vs + | NONE => ValSet.empty +end diff --git a/src/sql.sig b/src/sql.sig new file mode 100644 index 00000000..540844c3 --- /dev/null +++ b/src/sql.sig @@ -0,0 +1,79 @@ +signature SQL = sig + +val fu : Mono.file -> unit + +val debug : bool ref + +type lvar + +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 reln = + Known + | Sql of string + | PCon0 of string + | PCon1 of string + | Eq + | Ne + | Lt + | Le + | Gt + | Ge + +datatype prop = + True + | False + | Unknown + | And of prop * prop + | Or of prop * prop + | Reln of reln * exp list + | Cond of exp * prop + +datatype ('a, 'b) sum = inl of 'a | inr of 'b + +datatype Rel = + Exps of exp * exp -> prop + | Props of prop * prop -> prop + +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 sitem = + SqField of string * string + | SqExp of sqexp * string + +type query1 + +datatype query = + Query1 of query1 + | Union of query * query + +datatype dml = + Insert of string * (string * sqexp) list + | Delete of string * sqexp + | Update of string * (string * sqexp) list * sqexp + +end diff --git a/src/sql.sml b/src/sql.sml index 601b3510..6ac8bc68 100644 --- a/src/sql.sml +++ b/src/sql.sml @@ -2,7 +2,7 @@ structure Sql = struct open Mono -val debug = ref true (*false*) +val debug = ref false type lvar = int @@ -425,81 +425,4 @@ datatype querydml = val querydml = log "querydml" (altL [wrap dml Dml, wrap query Query]) -(* New stuff. *) - -fun subExps' (exp' : Mono.exp') = - case exp' of - ECon (_,_,SOME exp) => [exp] - | ESome (_,exp) => [exp] - | EFfiApp (_,_,xs) => map #1 xs - | EApp (exp1,exp2) => [exp1, exp2] - | EAbs (_,_,_,exp) => [exp] - | EUnop (_,exp) => [exp] - | EBinop (_,_,exp1,exp2) => [exp1, exp2] - | ERecord xs => map #2 xs - | EField (exp,_) => [exp] - | ECase (exp,xs,_) => exp :: map #2 xs - | EStrcat (exp1,exp2) => [exp1,exp2] - | EError (exp,_) => [exp] - | EReturnBlob {blob=NONE, mimeType, ...} => [mimeType] - | EReturnBlob {blob=SOME exp, mimeType, ...} => [exp, mimeType] - | ERedirect (exp,_) => [exp] - | EWrite exp => [exp] - | ESeq (exp1,exp2) => [exp1, exp2] - | ELet (_,_,exp1,exp2) => [exp1, exp2] - | EClosure (_,xs) => xs - | EQuery {query, body, initial, ...} => [query, body, initial] - | EDml (exp,_) => [exp] - | ENextval exp => [exp] - | ESetval (exp1,exp2) => [exp1, exp2] - | EUnurlify (exp,_,_) => [exp] - | EJavaScript (_,exp) => [exp] - | ESignalReturn exp => [exp] - | ESignalBind (exp1,exp2) => [exp1, exp2] - | ESignalSource exp => [exp] - | EServerCall (exp,_,_,_) => [exp] - | ERecv (exp,_) => [exp] - | ESleep exp => [exp] - | ESpawn exp => [exp] - | _ => [] - -val subExps : Mono.exp -> Mono.exp list = subExps' o #1 - -fun println str = print (str ^ "\n") -fun printlnExp exp = (Print.print (MonoPrint.p_exp MonoEnv.empty exp); println "") - -fun tablesRead (Query1 {From=tablePairs, ...}) = map #1 tablePairs - | tablesRead (Union (q1,q2)) = tablesRead q1 @ tablesRead q2 - -fun tableTouched (Insert (tab,_)) = tab - | tableTouched (Delete (tab,_)) = tab - | tableTouched (Update (tab,_,_)) = tab - -fun goExp (exp : Mono.exp) = - case #1 exp of - EQuery {query=e, ...} => ( - case parse query e of - SOME q => println ("Query reads from " ^ String.concatWith ", " (tablesRead q)) - | NONE => println "Couldn't parse query"; - printlnExp exp; println "") - | EDml (e,_) => ( - case parse dml e of - SOME d => println ("DML touches " ^ tableTouched d) - | NONE => println "Couldn't parse DML"; - printlnExp exp; println "") - | ENextval _ => (printlnExp exp; println "") - | ESetval _ => (printlnExp exp; println "") - (* Recurse down the syntax tree. *) - | _ => app goExp (subExps exp) - -fun goDecl (decl : decl) = - case #1 decl of - DVal (_,_,_,exp,_) => goExp exp - | DValRec xs => app (goExp o #4) xs - | _ => () - -fun goFile (file : file) = app goDecl (#1 file) - -fun go file = (println "Doing SQL analysis.\n"; goFile file; ()) - end diff --git a/src/sql_cache.sml b/src/sql_cache.sml new file mode 100644 index 00000000..072eefb5 --- /dev/null +++ b/src/sql_cache.sml @@ -0,0 +1,179 @@ +structure SqlCache = struct + +open Sql +open Mono + +structure IS = IntBinarySet +structure IM = IntBinaryMap +structure StringKey = struct type ord_key = string val compare = String.compare end +structure SS = BinarySetFn (StringKey) +structure SM = BinaryMapFn (StringKey) +structure SIMM = MultimapFn (structure KeyMap = SM structure ValSet = IS) + +val rec tablesRead = + fn Query1 {From=tablePairs, ...} => SS.fromList (map #1 tablePairs) + | Union (q1,q2) => SS.union (tablesRead q1, tablesRead q2) + +val tableWritten = + fn Insert (tab, _) => tab + | Delete (tab, _) => tab + | Update (tab, _, _) => tab + +fun tablesInExp' exp' = + let + val nothing = {read = SS.empty, written = SS.empty} + in + case exp' of + EQuery {query=e, ...} => + (case parse query e of + SOME q => {read = tablesRead q, written = SS.empty} + | NONE => nothing) + | EDml (e, _) => + (case parse dml e of + SOME q => {read = SS.empty, written = SS.singleton (tableWritten q)} + | NONE => nothing) + | _ => nothing + end + +val tablesInExp = + let + fun addTables (exp', {read, written}) = + let val {read = r, written = w} = tablesInExp' exp' + in {read = SS.union (r, read), written = SS.union (w, written)} end + in + MonoUtil.Exp.fold {typ = #2, exp = addTables} + {read = SS.empty, written = SS.empty} + end + +fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc) +fun intTyp loc = (TFfi ("Basis", "int"), loc) +fun boolPat (b, loc) = (PCon (Enum, + PConFfi {mod = "Basis", datatyp = "bool", arg = NONE, + con = if b then "True" else "False"}, + NONE), + loc) +fun boolTyp loc = (TFfi ("Basis", "int"), loc) + +fun ffiAppExp (module, func, arg, loc) = + (EFfiApp (module, func, [(intExp (arg, loc), intTyp loc)]), loc) + +fun sequence (befores, center, afters, loc) = + List.foldr (fn (exp, seq) => (ESeq (exp, seq), loc)) + (List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc)) + center + afters) + befores + +fun antiguardUnit (cond, exp, loc) = + (ECase (cond, + [(boolPat (false, loc), exp), + (boolPat (true, loc), (ERecord [], loc))], + {disc = boolTyp loc, result = (TRecord [], loc)}), + loc) + +fun underAbs f (exp as (exp', loc)) = + case exp' of + EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc) + | _ => f exp + +fun addCacheCheck (index, exp) = + let + fun f (body as (_, loc)) = + let + val check = ffiAppExp ("Cache", "check", index, loc) + val store = ffiAppExp ("Cache", "store", index, loc) + in + antiguardUnit (check, sequence ([], body, [store], loc), loc) + end + in + underAbs f exp + end + +fun addCacheFlush (exp, tablesToIndices) = + let + fun addIndices (table, indices) = IS.union (indices, SIMM.find (tablesToIndices, table)) + fun f (body as (_, loc)) = + let + fun mapFfi func = List.map (fn i => ffiAppExp ("Cache", func, i, loc)) + val flushes = + IS.listItems (SS.foldr addIndices IS.empty (#written (tablesInExp body))) + + in + sequence (mapFfi "flush" flushes, body, mapFfi "ready" flushes, loc) + end + in + underAbs f exp + end + +val handlerIndices = + let + val isUnit = + fn (TRecord [], _) => true + | _ => false + fun maybeAdd (d, soFar as {readers, writers}) = + case d of + DExport (Link ReadOnly, _, name, typs, typ, _) => + if List.all isUnit (typ::typs) + then {readers = IS.add (readers, name), writers = writers} + else soFar + | DExport (_, _, name, _, _, _) => (* Not read only. *) + {readers = readers, writers = IS.add (writers, name)} + | _ => soFar + in + MonoUtil.File.fold {typ = #2, exp = #2, decl = maybeAdd} + {readers = IS.empty, writers = IS.empty} + end + +fun fileFoldMapiSelected f init (file, indices) = + let + fun doExp (original as ((a, index, b, exp, c), state)) = + if IS.member (indices, index) + then let val (newExp, newState) = f (index, exp, state) + in ((a, index, b, newExp, c), newState) end + else original + fun doDecl decl state = + let + val result = + case decl of + DVal x => + let val (y, newState) = doExp (x, state) + in (DVal y, newState) end + | DValRec xs => + let val (ys, newState) = ListUtil.foldlMap doExp state xs + in (DValRec ys, newState) end + | _ => (decl, state) + in + Search.Continue result + end + fun nada x y = Search.Continue (x, y) + in + case MonoUtil.File.mapfold {typ = nada, exp = nada, decl = doDecl} file init of + Search.Continue x => x + | _ => (file, init) (* Should never happen. *) + end + +fun fileMapSelected f = #1 o fileFoldMapiSelected (fn (_, x, _) => (f x, ())) () + +val addCacheChecking = + let + fun f (index, exp, tablesToIndices) = + (addCacheCheck (index, exp), + SS.foldr (fn (table, tsToIs) => SIMM.insert (tsToIs, table, index)) + tablesToIndices + (#read (tablesInExp exp))) + in + fileFoldMapiSelected f (SM.empty) + end + +fun addCacheFlushing (file, tablesToIndices, writers) = + fileMapSelected (fn exp => addCacheFlush (exp, tablesToIndices)) (file, writers) + +fun go file = + let + val {readers, writers} = handlerIndices file + val (fileWithChecks, tablesToIndices) = addCacheChecking (file, readers) + in + addCacheFlushing (fileWithChecks, tablesToIndices, writers) + end + +end -- cgit v1.2.3 From b1516ed386ca303a526959586f0a06564ca77bb0 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Tue, 27 May 2014 21:14:13 -0400 Subject: Finishes initial prototype, caching parameterless pages with table-match-based invalidation. Still has problems parsing non-Postgres SQL dialects properly. --- caching-tests/test.db | Bin 0 -> 3072 bytes caching-tests/test.sql | 11 +++++ caching-tests/test.ur | 112 +++++++++++++++++----------------------------- caching-tests/test.urp | 3 +- include/urweb/urweb_cpp.h | 4 ++ src/c/urweb.c | 18 ++++++++ src/cjr_print.sml | 66 ++++++++++++++++++++++----- src/compiler.sml | 2 +- src/sources | 5 +++ src/sql.sig | 22 ++++++--- src/sql.sml | 2 +- src/sql_cache.sml | 11 ++++- 12 files changed, 165 insertions(+), 91 deletions(-) create mode 100644 caching-tests/test.db create mode 100644 caching-tests/test.sql (limited to 'src/compiler.sml') diff --git a/caching-tests/test.db b/caching-tests/test.db new file mode 100644 index 00000000..190d2868 Binary files /dev/null and b/caching-tests/test.db differ diff --git a/caching-tests/test.sql b/caching-tests/test.sql new file mode 100644 index 00000000..862245b7 --- /dev/null +++ b/caching-tests/test.sql @@ -0,0 +1,11 @@ +CREATE TABLE uw_Test_foo01(uw_id integer NOT NULL, uw_bar text NOT NULL, + PRIMARY KEY (uw_id) + + ); + + CREATE TABLE uw_Test_foo10(uw_id integer NOT NULL, uw_bar text 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 4703e229..d13379a8 100644 --- a/caching-tests/test.ur +++ b/caching-tests/test.ur @@ -1,81 +1,53 @@ table foo01 : {Id : int, Bar : string} PRIMARY KEY Id table foo10 : {Id : int, Bar : string} PRIMARY KEY Id -(* val query = (SELECT * FROM foo WHERE foo.Bar = "baz") *) -(* val insert = (INSERT INTO foo (Id, Bar) VALUES (42, "baz")) *) +fun flush01 () : transaction page = + dml (INSERT INTO foo01 (Id, Bar) VALUES (42, "baz01")); + dml (UPDATE foo01 SET Bar = "baz01" WHERE Id = 42); + return + Flushed 1! + -fun flush01 () : transaction page= - dml (INSERT INTO foo01 (Id, Bar) VALUES (42, "baz")); - return - - - Flushed 1! - - +fun flush10 () : transaction page = + dml (UPDATE foo10 SET Bar = "baz10" WHERE Id = 42); + return + Flushed 2! + -fun flush10 () : transaction page= - dml (INSERT INTO foo10 (Id, Bar) VALUES (42, "baz")); - return - - - Flushed 2! - - - -fun flush11 () : transaction page= - dml (INSERT INTO foo01 (Id, Bar) VALUES (42, "baz")); - dml (INSERT INTO foo10 (Id, Bar) VALUES (42, "baz")); - return - - - Flushed 1 and 2! - - +fun flush11 () : transaction page = + dml (UPDATE foo01 SET Bar = "baz11" WHERE Id = 42); + dml (UPDATE foo10 SET Bar = "baz11" WHERE Id = 42); + return + Flushed 1 and 2! + fun cache01 () : transaction page = - res <- oneOrNoRows (SELECT foo01.Id, foo01.Bar - FROM foo01 - WHERE foo01.Bar = "baz"); - return - - - Reading 1. - {case res of - None => - | Some row => {[row.Foo01.Bar]}} - - + res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42); + return + Reading 1. + {case res of + None => + | Some row => {[row.Foo01.Bar]}} + fun cache10 () : transaction page = - res <- oneOrNoRows (SELECT foo10.Id, foo10.Bar - FROM foo10 - WHERE foo10.Bar = "baz"); - return - - - Reading 2. - {case res of - None => - | Some row => {[row.Foo10.Bar]}} - - + res <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42); + return + Reading 2. + {case res of + None => + | Some row => {[row.Foo10.Bar]}} + fun cache11 () : transaction page = - res <- oneOrNoRows (SELECT foo01.Id, foo01.Bar - FROM foo01 - WHERE foo01.Bar = "baz"); - bla <- oneOrNoRows (SELECT foo10.Id, foo10.Bar - FROM foo10 - WHERE foo10.Bar = "baz"); - return - - - Reading 1 and 2. - {case res of - None => - | Some row => {[row.Foo01.Bar]}} - {case bla of - None => - | Some row => {[row.Foo10.Bar]}} - - + res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42); + bla <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42); + return + Reading 1 and 2. + {case res of + None => + | Some row => {[row.Foo01.Bar]}} + {case bla of + None => + | Some row => {[row.Foo10.Bar]}} + diff --git a/caching-tests/test.urp b/caching-tests/test.urp index e5111220..123f58e5 100644 --- a/caching-tests/test.urp +++ b/caching-tests/test.urp @@ -1,4 +1,5 @@ -database dbname=test +database test.db +sql test.sql safeGet Test/flush01 safeGet Test/flush10 safeGet Test/flush11 diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index 1bb6b2f2..799d0861 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -75,6 +75,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 ffcc0146..d4c0b439 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; }; size_t uw_headers_max = SIZE_MAX; @@ -560,6 +563,8 @@ uw_context uw_init(int id, void *logger_data, uw_logger log_debug) { ctx->output_buffer = malloc(1); ctx->output_buffer_size = 1; + ctx->recording = 0; + return ctx; } @@ -1636,6 +1641,19 @@ void uw_write(uw_context ctx, const char* s) { *ctx->page.front = 0; } +void uw_recordingStart(uw_context ctx) { + // TODO: remove following debug statement. + uw_write(ctx, ""); + ctx->recording = ctx->page.front; +} + +char *uw_recordingRead(uw_context ctx) { + char *recording = strdup(ctx->recording); + // TODO: remove following debug statement. + uw_write(ctx, ""); + return 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 05dce35e..ecd29f71 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', @@ -3378,6 +3378,50 @@ fun p_file env (ds, ps) = newline, newline, + (* For caching. *) + box (List.map + (fn index => + let val i = Int.toString index + in box [string "static char *cache", + string i, + string " = NULL;", + newline, + string "static uw_Basis_bool uw_Cache_check", + string i, + string "(uw_context ctx) { puts(\"Checked ", + string i, + string "\"); if (cache", + string i, + string " == NULL) { uw_recordingStart(ctx); return uw_Basis_False; } else { uw_write(ctx, cache", + string i, + string "); return uw_Basis_True; } };", + newline, + string "static uw_unit uw_Cache_store", + string i, + string "(uw_context ctx) { cache", + string i, + string " = uw_recordingRead(ctx); puts(\"Stored ", + string i, + string "\"); return uw_unit_v; };", + newline, + string "static uw_unit uw_Cache_flush", + string i, + string "(uw_context ctx) { free(cache", + string i, + string "); cache", + string i, + string " = NULL; puts(\"Flushed ", + string i, + string "\"); return uw_unit_v; };", + newline, + string "static uw_unit uw_Cache_ready", + string i, + string "(uw_context ctx) { return uw_unit_v; };", + newline, + newline] + end) + (!SqlCache.ffiIndices)), + newline, p_list_sep newline (fn x => x) pds, newline, @@ -3433,7 +3477,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;", @@ -3480,7 +3524,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, diff --git a/src/compiler.sml b/src/compiler.sml index de10d8c8..37272758 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -606,7 +606,7 @@ fun parseUrp' accLibs fname = filterEnv = rev (!env), sources = sources, protocol = !protocol, - dbms = !dbms, + dbms = (*!dbms*) SOME "sqlite", sigFile = !sigFile, safeGets = rev (!safeGets), onError = !onError, diff --git a/src/sources b/src/sources index f75803a3..b468c9a5 100644 --- a/src/sources +++ b/src/sources @@ -186,8 +186,13 @@ $(SRC)/mono_shake.sml $(SRC)/fuse.sig $(SRC)/fuse.sml +$(SRC)/sql.sig $(SRC)/sql.sml +$(SRC)/multimap_fn.sml + +$(SRC)/sql_cache.sml + $(SRC)/iflow.sig $(SRC)/iflow.sml diff --git a/src/sql.sig b/src/sql.sig index 540844c3..573a8baf 100644 --- a/src/sql.sig +++ b/src/sql.sig @@ -1,10 +1,8 @@ signature SQL = sig -val fu : Mono.file -> unit - val debug : bool ref -type lvar +type lvar = int datatype func = DtCon0 of string @@ -41,7 +39,13 @@ datatype prop = | Reln of reln * exp list | Cond of exp * prop -datatype ('a, 'b) sum = inl of 'a | inr of 'b +datatype chunk = + String of string + | Exp of Mono.exp + +type 'a parser = chunk list -> ('a * chunk list) option + +val parse : 'a parser -> Mono.exp -> 'a option datatype Rel = Exps of exp * exp -> prop @@ -61,19 +65,27 @@ datatype 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 +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 6ac8bc68..8642c9d2 100644 --- a/src/sql.sml +++ b/src/sql.sml @@ -1,4 +1,4 @@ -structure Sql = struct +structure Sql :> SQL = struct open Mono diff --git a/src/sql_cache.sml b/src/sql_cache.sml index 072eefb5..7f9d98d0 100644 --- a/src/sql_cache.sml +++ b/src/sql_cache.sml @@ -10,6 +10,10 @@ structure SS = BinarySetFn (StringKey) structure SM = BinaryMapFn (StringKey) structure SIMM = MultimapFn (structure KeyMap = SM structure ValSet = IS) +val ffiIndices : int list ref = ref [] +val rs : int list ref = ref [] +val ws : int list ref = ref [] + val rec tablesRead = fn Query1 {From=tablePairs, ...} => SS.fromList (map #1 tablePairs) | Union (q1,q2) => SS.union (tablesRead q1, tablesRead q2) @@ -54,8 +58,8 @@ fun boolPat (b, loc) = (PCon (Enum, loc) fun boolTyp loc = (TFfi ("Basis", "int"), loc) -fun ffiAppExp (module, func, arg, loc) = - (EFfiApp (module, func, [(intExp (arg, loc), intTyp loc)]), loc) +fun ffiAppExp (module, func, index, loc) = + (EFfiApp (module, func ^ Int.toString index, []), loc) fun sequence (befores, center, afters, loc) = List.foldr (fn (exp, seq) => (ESeq (exp, seq), loc)) @@ -173,6 +177,9 @@ fun go file = val {readers, writers} = handlerIndices file val (fileWithChecks, tablesToIndices) = addCacheChecking (file, readers) in + rs := IS.listItems readers; + ws := IS.listItems writers; + ffiIndices := IS.listItems readers; addCacheFlushing (fileWithChecks, tablesToIndices, writers) end -- cgit v1.2.3 From 8766bd82ba931a28976319fe5bd76dc97d1218d6 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Fri, 30 May 2014 12:00:00 -0400 Subject: Removes DBMS choice override from compiler.sml (which was there for debugging). --- src/compiler.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/compiler.sml') diff --git a/src/compiler.sml b/src/compiler.sml index fd143485..cbc6478d 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -606,7 +606,7 @@ fun parseUrp' accLibs fname = filterEnv = rev (!env), sources = sources, protocol = !protocol, - dbms = (*!dbms*) SOME "sqlite", + dbms = !dbms, sigFile = !sigFile, safeGets = rev (!safeGets), onError = !onError, -- cgit v1.2.3 From 171e5ecea687a43033e92c98c0661cc161d50e4a Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Sat, 31 May 2014 03:08:16 -0400 Subject: Cleans up interface (it's now a command line option) and renames project to "sqlcache" in the all-one-word style. Still has issues to do with concurrency, retrying transactions, and foreign function calls that either rely on state or have side effects. --- caching-tests/test.ur | 1 - src/c/urweb.c | 7 +- src/cjr_print.sml | 14 ++-- src/compiler.sig | 5 +- src/compiler.sml | 9 +-- src/main.mlton.sml | 12 ++-- src/sources | 9 +-- src/sql.sml | 20 +++--- src/sql_cache.sml | 186 -------------------------------------------------- src/sqlcache.sig | 6 ++ src/sqlcache.sml | 182 ++++++++++++++++++++++++++++++++++++++++++++++++ 11 files changed, 227 insertions(+), 224 deletions(-) delete mode 100644 src/sql_cache.sml create mode 100644 src/sqlcache.sig create mode 100644 src/sqlcache.sml (limited to 'src/compiler.sml') diff --git a/caching-tests/test.ur b/caching-tests/test.ur index d13379a8..a99a387b 100644 --- a/caching-tests/test.ur +++ b/caching-tests/test.ur @@ -2,7 +2,6 @@ table foo01 : {Id : int, Bar : string} PRIMARY KEY Id table foo10 : {Id : int, Bar : string} PRIMARY KEY Id fun flush01 () : transaction page = - dml (INSERT INTO foo01 (Id, Bar) VALUES (42, "baz01")); dml (UPDATE foo01 SET Bar = "baz01" WHERE Id = 42); return Flushed 1! diff --git a/src/c/urweb.c b/src/c/urweb.c index 10bbf930..57762da8 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -1667,16 +1667,11 @@ void uw_write(uw_context ctx, const char* s) { } void uw_recordingStart(uw_context ctx) { - // TODO: remove following debug statement. - uw_write(ctx, ""); ctx->recording = ctx->page.front; } char *uw_recordingRead(uw_context ctx) { - char *recording = strdup(ctx->recording); - // TODO: remove following debug statement. - uw_write(ctx, ""); - return recording; + return strdup(ctx->recording); } char *uw_Basis_attrifyInt(uw_context ctx, uw_Basis_int n) { diff --git a/src/cjr_print.sml b/src/cjr_print.sml index ecd29f71..af2340fe 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3388,9 +3388,9 @@ fun p_file env (ds, ps) = newline, string "static uw_Basis_bool uw_Cache_check", string i, - string "(uw_context ctx) { puts(\"Checked ", + string "(uw_context ctx) { puts(\"Checked cache ", string i, - string "\"); if (cache", + string ".\"); if (cache", string i, string " == NULL) { uw_recordingStart(ctx); return uw_Basis_False; } else { uw_write(ctx, cache", string i, @@ -3400,9 +3400,9 @@ fun p_file env (ds, ps) = string i, string "(uw_context ctx) { cache", string i, - string " = uw_recordingRead(ctx); puts(\"Stored ", + string " = uw_recordingRead(ctx); puts(\"Stored cache ", string i, - string "\"); return uw_unit_v; };", + string ".\"); return uw_unit_v; };", newline, string "static uw_unit uw_Cache_flush", string i, @@ -3410,9 +3410,9 @@ fun p_file env (ds, ps) = string i, string "); cache", string i, - string " = NULL; puts(\"Flushed ", + string " = NULL; puts(\"Flushed cache ", string i, - string "\"); return uw_unit_v; };", + string ".\"); return uw_unit_v; };", newline, string "static uw_unit uw_Cache_ready", string i, @@ -3420,7 +3420,7 @@ fun p_file env (ds, ps) = newline, newline] end) - (!SqlCache.ffiIndices)), + (!Sqlcache.ffiIndices)), newline, p_list_sep newline (fn x => x) pds, diff --git a/src/compiler.sig b/src/compiler.sig index a0a653a7..81d92694 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -122,7 +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 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 @@ -187,7 +187,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 toSqlcache : (string, Mono.file) transform val toCjrize : (string, Cjr.file) transform val toPrepare : (string, Cjr.file) transform val toChecknest : (string, Cjr.file) transform @@ -198,6 +198,7 @@ signature COMPILER = sig val enableBoot : unit -> unit val doIflow : bool ref + val doSqlcache : bool ref val addPath : string * string -> unit val addModuleRoot : string * string -> unit diff --git a/src/compiler.sml b/src/compiler.sml index cbc6478d..26e07e2a 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -83,6 +83,7 @@ type ('src, 'dst) transform = { val debug = ref false val dumpSource = ref false val doIflow = ref false +val doSqlcache = ref false val doDumpSource = ref (fn () => ()) @@ -1439,19 +1440,19 @@ val sigcheck = { val toSigcheck = transform sigcheck "sigcheck" o toSidecheck -val sqlCache = { - func = SqlCache.go, +val sqlcache = { + func = (fn file => (if !doSqlcache then Sqlcache.go file else file)), print = MonoPrint.p_file MonoEnv.empty } -val toSqlCache = transform sqlCache "sqlCache" o toSigcheck +val toSqlcache = transform sqlcache "sqlcache" o toSigcheck val cjrize = { func = Cjrize.cjrize, print = CjrPrint.p_file CjrEnv.empty } -val toCjrize = transform cjrize "cjrize" o toSqlCache +val toCjrize = transform cjrize "cjrize" o toSqlcache val prepare = { func = Prepare.prepare, diff --git a/src/main.mlton.sml b/src/main.mlton.sml index bfc18e59..5ecd7290 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 @@ -47,6 +47,7 @@ fun oneRun args = Elaborate.unifyMore := false; Compiler.dumpSource := false; Compiler.doIflow := false; + Compiler.doSqlcache := false; Demo.noEmacs := false; Settings.setDebug false) @@ -64,7 +65,7 @@ fun oneRun args = fun doArgs args = case args of [] => () - | "-version" :: rest => + | "-version" :: rest => printVersion () | "-numeric-version" :: rest => printNumericVersion () @@ -159,6 +160,9 @@ fun oneRun args = | "-iflow" :: rest => (Compiler.doIflow := true; doArgs rest) + | "-sqlcache" :: rest => + (Compiler.doSqlcache := true; + doArgs rest) | "-moduleOf" :: fname :: _ => (print (Compiler.moduleOf fname ^ "\n"); raise Code OS.Process.success) @@ -306,7 +310,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 +329,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/sources b/src/sources index b468c9a5..a87678f9 100644 --- a/src/sources +++ b/src/sources @@ -189,10 +189,6 @@ $(SRC)/fuse.sml $(SRC)/sql.sig $(SRC)/sql.sml -$(SRC)/multimap_fn.sml - -$(SRC)/sql_cache.sml - $(SRC)/iflow.sig $(SRC)/iflow.sml @@ -211,6 +207,11 @@ $(SRC)/sidecheck.sml $(SRC)/sigcheck.sig $(SRC)/sigcheck.sml +$(SRC)/multimap_fn.sml + +$(SRC)/sqlcache.sig +$(SRC)/sqlcache.sml + $(SRC)/cjr.sml $(SRC)/postgres.sig diff --git a/src/sql.sml b/src/sql.sml index 8642c9d2..11df715c 100644 --- a/src/sql.sml +++ b/src/sql.sml @@ -177,10 +177,10 @@ 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 @@ -396,22 +396,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/sql_cache.sml b/src/sql_cache.sml deleted file mode 100644 index 7f9d98d0..00000000 --- a/src/sql_cache.sml +++ /dev/null @@ -1,186 +0,0 @@ -structure SqlCache = struct - -open Sql -open Mono - -structure IS = IntBinarySet -structure IM = IntBinaryMap -structure StringKey = struct type ord_key = string val compare = String.compare end -structure SS = BinarySetFn (StringKey) -structure SM = BinaryMapFn (StringKey) -structure SIMM = MultimapFn (structure KeyMap = SM structure ValSet = IS) - -val ffiIndices : int list ref = ref [] -val rs : int list ref = ref [] -val ws : int list ref = ref [] - -val rec tablesRead = - fn Query1 {From=tablePairs, ...} => SS.fromList (map #1 tablePairs) - | Union (q1,q2) => SS.union (tablesRead q1, tablesRead q2) - -val tableWritten = - fn Insert (tab, _) => tab - | Delete (tab, _) => tab - | Update (tab, _, _) => tab - -fun tablesInExp' exp' = - let - val nothing = {read = SS.empty, written = SS.empty} - in - case exp' of - EQuery {query=e, ...} => - (case parse query e of - SOME q => {read = tablesRead q, written = SS.empty} - | NONE => nothing) - | EDml (e, _) => - (case parse dml e of - SOME q => {read = SS.empty, written = SS.singleton (tableWritten q)} - | NONE => nothing) - | _ => nothing - end - -val tablesInExp = - let - fun addTables (exp', {read, written}) = - let val {read = r, written = w} = tablesInExp' exp' - in {read = SS.union (r, read), written = SS.union (w, written)} end - in - MonoUtil.Exp.fold {typ = #2, exp = addTables} - {read = SS.empty, written = SS.empty} - end - -fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc) -fun intTyp loc = (TFfi ("Basis", "int"), loc) -fun boolPat (b, loc) = (PCon (Enum, - PConFfi {mod = "Basis", datatyp = "bool", arg = NONE, - con = if b then "True" else "False"}, - NONE), - loc) -fun boolTyp loc = (TFfi ("Basis", "int"), loc) - -fun ffiAppExp (module, func, index, loc) = - (EFfiApp (module, func ^ Int.toString index, []), loc) - -fun sequence (befores, center, afters, loc) = - List.foldr (fn (exp, seq) => (ESeq (exp, seq), loc)) - (List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc)) - center - afters) - befores - -fun antiguardUnit (cond, exp, loc) = - (ECase (cond, - [(boolPat (false, loc), exp), - (boolPat (true, loc), (ERecord [], loc))], - {disc = boolTyp loc, result = (TRecord [], loc)}), - loc) - -fun underAbs f (exp as (exp', loc)) = - case exp' of - EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc) - | _ => f exp - -fun addCacheCheck (index, exp) = - let - fun f (body as (_, loc)) = - let - val check = ffiAppExp ("Cache", "check", index, loc) - val store = ffiAppExp ("Cache", "store", index, loc) - in - antiguardUnit (check, sequence ([], body, [store], loc), loc) - end - in - underAbs f exp - end - -fun addCacheFlush (exp, tablesToIndices) = - let - fun addIndices (table, indices) = IS.union (indices, SIMM.find (tablesToIndices, table)) - fun f (body as (_, loc)) = - let - fun mapFfi func = List.map (fn i => ffiAppExp ("Cache", func, i, loc)) - val flushes = - IS.listItems (SS.foldr addIndices IS.empty (#written (tablesInExp body))) - - in - sequence (mapFfi "flush" flushes, body, mapFfi "ready" flushes, loc) - end - in - underAbs f exp - end - -val handlerIndices = - let - val isUnit = - fn (TRecord [], _) => true - | _ => false - fun maybeAdd (d, soFar as {readers, writers}) = - case d of - DExport (Link ReadOnly, _, name, typs, typ, _) => - if List.all isUnit (typ::typs) - then {readers = IS.add (readers, name), writers = writers} - else soFar - | DExport (_, _, name, _, _, _) => (* Not read only. *) - {readers = readers, writers = IS.add (writers, name)} - | _ => soFar - in - MonoUtil.File.fold {typ = #2, exp = #2, decl = maybeAdd} - {readers = IS.empty, writers = IS.empty} - end - -fun fileFoldMapiSelected f init (file, indices) = - let - fun doExp (original as ((a, index, b, exp, c), state)) = - if IS.member (indices, index) - then let val (newExp, newState) = f (index, exp, state) - in ((a, index, b, newExp, c), newState) end - else original - fun doDecl decl state = - let - val result = - case decl of - DVal x => - let val (y, newState) = doExp (x, state) - in (DVal y, newState) end - | DValRec xs => - let val (ys, newState) = ListUtil.foldlMap doExp state xs - in (DValRec ys, newState) end - | _ => (decl, state) - in - Search.Continue result - end - fun nada x y = Search.Continue (x, y) - in - case MonoUtil.File.mapfold {typ = nada, exp = nada, decl = doDecl} file init of - Search.Continue x => x - | _ => (file, init) (* Should never happen. *) - end - -fun fileMapSelected f = #1 o fileFoldMapiSelected (fn (_, x, _) => (f x, ())) () - -val addCacheChecking = - let - fun f (index, exp, tablesToIndices) = - (addCacheCheck (index, exp), - SS.foldr (fn (table, tsToIs) => SIMM.insert (tsToIs, table, index)) - tablesToIndices - (#read (tablesInExp exp))) - in - fileFoldMapiSelected f (SM.empty) - end - -fun addCacheFlushing (file, tablesToIndices, writers) = - fileMapSelected (fn exp => addCacheFlush (exp, tablesToIndices)) (file, writers) - -fun go file = - let - val {readers, writers} = handlerIndices file - val (fileWithChecks, tablesToIndices) = addCacheChecking (file, readers) - in - rs := IS.listItems readers; - ws := IS.listItems writers; - ffiIndices := IS.listItems readers; - addCacheFlushing (fileWithChecks, tablesToIndices, writers) - end - -end 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..2e7f6e42 --- /dev/null +++ b/src/sqlcache.sml @@ -0,0 +1,182 @@ +structure Sqlcache :> SQLCACHE = struct + +open Sql +open Mono + +structure IS = IntBinarySet +structure IM = IntBinaryMap +structure StringKey = struct type ord_key = string val compare = String.compare end +structure SS = BinarySetFn (StringKey) +structure SM = BinaryMapFn (StringKey) +structure SIMM = MultimapFn (structure KeyMap = SM structure ValSet = IS) + +val ffiIndices : int list ref = ref [] + +val rec tablesRead = + fn Query1 {From=tablePairs, ...} => SS.fromList (map #1 tablePairs) + | Union (q1,q2) => SS.union (tablesRead q1, tablesRead q2) + +val tableWritten = + fn Insert (tab, _) => tab + | Delete (tab, _) => tab + | Update (tab, _, _) => tab + +fun tablesInExp' exp' = + let + val nothing = {read = SS.empty, written = SS.empty} + in + case exp' of + EQuery {query=e, ...} => + (case parse query e of + SOME q => {read = tablesRead q, written = SS.empty} + | NONE => nothing) + | EDml (e, _) => + (case parse dml e of + SOME q => {read = SS.empty, written = SS.singleton (tableWritten q)} + | NONE => nothing) + | _ => nothing + end + +val tablesInExp = + let + fun addTables (exp', {read, written}) = + let val {read = r, written = w} = tablesInExp' exp' + in {read = SS.union (r, read), written = SS.union (w, written)} end + in + MonoUtil.Exp.fold {typ = #2, exp = addTables} + {read = SS.empty, written = SS.empty} + end + +fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc) +fun intTyp loc = (TFfi ("Basis", "int"), loc) +fun boolPat (b, loc) = (PCon (Enum, + PConFfi {mod = "Basis", datatyp = "bool", arg = NONE, + con = if b then "True" else "False"}, + NONE), + loc) +fun boolTyp loc = (TFfi ("Basis", "int"), loc) + +fun ffiAppExp (module, func, index, loc) = + (EFfiApp (module, func ^ Int.toString index, []), loc) + +fun sequence (befores, center, afters, loc) = + List.foldr (fn (exp, seq) => (ESeq (exp, seq), loc)) + (List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc)) + center + afters) + befores + +fun antiguardUnit (cond, exp, loc) = + (ECase (cond, + [(boolPat (false, loc), exp), + (boolPat (true, loc), (ERecord [], loc))], + {disc = boolTyp loc, result = (TRecord [], loc)}), + loc) + +fun underAbs f (exp as (exp', loc)) = + case exp' of + EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc) + | _ => f exp + +fun addCacheCheck (index, exp) = + let + fun f (body as (_, loc)) = + let + val check = ffiAppExp ("Cache", "check", index, loc) + val store = ffiAppExp ("Cache", "store", index, loc) + in + antiguardUnit (check, sequence ([], body, [store], loc), loc) + end + in + underAbs f exp + end + +fun addCacheFlush (exp, tablesToIndices) = + let + fun addIndices (table, indices) = IS.union (indices, SIMM.find (tablesToIndices, table)) + fun f (body as (_, loc)) = + let + fun mapFfi func = List.map (fn i => ffiAppExp ("Cache", func, i, loc)) + val flushes = + IS.listItems (SS.foldr addIndices IS.empty (#written (tablesInExp body))) + + in + sequence (mapFfi "flush" flushes, body, mapFfi "ready" flushes, loc) + end + in + underAbs f exp + end + +val handlerIndices = + let + val isUnit = + fn (TRecord [], _) => true + | _ => false + fun maybeAdd (d, soFar as {readers, writers}) = + case d of + DExport (Link ReadOnly, _, name, typs, typ, _) => + if List.all isUnit (typ::typs) + then {readers = IS.add (readers, name), writers = writers} + else soFar + | DExport (_, _, name, _, _, _) => (* Not read only. *) + {readers = readers, writers = IS.add (writers, name)} + | _ => soFar + in + MonoUtil.File.fold {typ = #2, exp = #2, decl = maybeAdd} + {readers = IS.empty, writers = IS.empty} + end + +fun fileFoldMapiSelected f init (file, indices) = + let + fun doExp (original as ((a, index, b, exp, c), state)) = + if IS.member (indices, index) + then let val (newExp, newState) = f (index, exp, state) + in ((a, index, b, newExp, c), newState) end + else original + fun doDecl decl state = + let + val result = + case decl of + DVal x => + let val (y, newState) = doExp (x, state) + in (DVal y, newState) end + | DValRec xs => + let val (ys, newState) = ListUtil.foldlMap doExp state xs + in (DValRec ys, newState) end + | _ => (decl, state) + in + Search.Continue result + end + fun nada x y = Search.Continue (x, y) + in + case MonoUtil.File.mapfold {typ = nada, exp = nada, decl = doDecl} file init of + Search.Continue x => x + | _ => (file, init) (* Should never happen. *) + end + +fun fileMapSelected f = #1 o fileFoldMapiSelected (fn (_, x, _) => (f x, ())) () + +val addCacheChecking = + let + fun f (index, exp, tablesToIndices) = + (addCacheCheck (index, exp), + SS.foldr (fn (table, tsToIs) => SIMM.insert (tsToIs, table, index)) + tablesToIndices + (#read (tablesInExp exp))) + in + fileFoldMapiSelected f (SM.empty) + end + +fun addCacheFlushing (file, tablesToIndices, writers) = + fileMapSelected (fn exp => addCacheFlush (exp, tablesToIndices)) (file, writers) + +fun go file = + let + val {readers, writers} = handlerIndices file + val (fileWithChecks, tablesToIndices) = addCacheChecking (file, readers) + in + ffiIndices := IS.listItems readers; + addCacheFlushing (fileWithChecks, tablesToIndices, writers) + end + +end -- cgit v1.2.3 From 75d1eedd15edc41b1c2bc9d1fce7a74f37bd78a1 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Tue, 14 Oct 2014 18:05:09 -0400 Subject: Complete overhaul: cache queries based on immediate query result, not eventual HTML output. --- caching-tests/test.db | Bin 3072 -> 5120 bytes caching-tests/test.sql | 7 +- caching-tests/test.ur | 74 +++++++++----- caching-tests/test.urp | 1 + caching-tests/test.urs | 2 + src/cjr_print.sml | 70 +++++++++---- src/compiler.sig | 1 - src/compiler.sml | 6 +- src/monoize.sig | 2 +- src/monoize.sml | 24 +++-- src/multimap_fn.sml | 10 +- src/settings.sig | 3 + src/settings.sml | 4 + src/sources | 2 + src/sql.sig | 2 + src/sql.sml | 20 +++- src/sqlcache.sml | 266 +++++++++++++++++++++++++++++++++++++++++++++---- 17 files changed, 411 insertions(+), 83 deletions(-) (limited to 'src/compiler.sml') diff --git a/caching-tests/test.db b/caching-tests/test.db index a5c91e8f..944aa851 100644 Binary files a/caching-tests/test.db and b/caching-tests/test.db differ diff --git a/caching-tests/test.sql b/caching-tests/test.sql index 862245b7..efa271ec 100644 --- a/caching-tests/test.sql +++ b/caching-tests/test.sql @@ -8,4 +8,9 @@ CREATE TABLE uw_Test_foo01(uw_id integer NOT NULL, uw_bar text NOT NULL, ); - \ No newline at end of file + CREATE TABLE uw_Test_tab(uw_id integer NOT NULL, uw_val integer NOT NULL, + PRIMARY KEY (uw_id) + + ); + + \ No newline at end of file diff --git a/caching-tests/test.ur b/caching-tests/test.ur index a99a387b..cb391da7 100644 --- a/caching-tests/test.ur +++ b/caching-tests/test.ur @@ -1,52 +1,74 @@ table foo01 : {Id : int, Bar : string} PRIMARY KEY Id table foo10 : {Id : int, Bar : string} PRIMARY KEY Id +table tab : {Id : int, Val : int} PRIMARY KEY Id -fun flush01 () : transaction page = - dml (UPDATE foo01 SET Bar = "baz01" WHERE Id = 42); - return - Flushed 1! - - -fun flush10 () : transaction page = - dml (UPDATE foo10 SET Bar = "baz10" WHERE Id = 42); - return - Flushed 2! - - -fun flush11 () : transaction page = - dml (UPDATE foo01 SET Bar = "baz11" WHERE Id = 42); - dml (UPDATE foo10 SET Bar = "baz11" WHERE Id = 42); - return - Flushed 1 and 2! - - -fun cache01 () : transaction page = +fun cache01 () = res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42); return Reading 1. {case res of - None => + None => ? | Some row => {[row.Foo01.Bar]}} -fun cache10 () : transaction page = +fun cache10 () = res <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42); return Reading 2. {case res of - None => + None => ? | Some row => {[row.Foo10.Bar]}} -fun cache11 () : transaction page = +fun cache11 () = res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42); bla <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42); return Reading 1 and 2. {case res of - None => + None => ? | Some row => {[row.Foo01.Bar]}} {case bla of - None => + None => ? | Some row => {[row.Foo10.Bar]}} + +fun flush01 () = + dml (UPDATE foo01 SET Bar = "baz01" WHERE Id = 42); + return + Flushed 1! + + +fun flush10 () = + dml (UPDATE foo10 SET Bar = "baz10" WHERE Id = 42); + return + Flushed 2! + + +fun flush11 () = + dml (UPDATE foo01 SET Bar = "baz11" WHERE Id = 42); + dml (UPDATE foo10 SET Bar = "baz11" WHERE Id = 42); + return + Flushed 1 and 2! + + +fun cache id = + res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]}); + return + Reading {[id]}. + {case res of + None => ? + | Some row => {[row.Tab.Val]}} + + +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 + (* Flushed {[id]}! *) + {case res of + None => Initialized {[id]}! + | Some row => Incremented {[id]}!} + diff --git a/caching-tests/test.urp b/caching-tests/test.urp index 123f58e5..7ac469f9 100644 --- a/caching-tests/test.urp +++ b/caching-tests/test.urp @@ -3,5 +3,6 @@ sql test.sql safeGet Test/flush01 safeGet Test/flush10 safeGet Test/flush11 +safeGet Test/flush test diff --git a/caching-tests/test.urs b/caching-tests/test.urs index ce7d0350..ace4ba28 100644 --- a/caching-tests/test.urs +++ b/caching-tests/test.urs @@ -4,3 +4,5 @@ val cache11 : unit -> transaction page val flush01 : unit -> transaction page val flush10 : unit -> transaction page val flush11 : unit -> transaction page +val cache : int -> transaction page +val flush : int -> transaction page diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 8ca35234..6427cf3d 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3395,49 +3395,77 @@ fun p_file env (ds, ps) = (* For sqlcache. *) box (List.map - (fn index => + (fn {index, params} => let val i = Int.toString index + fun paramRepeat itemi sep = + let + val rec f = + fn 0 => itemi (Int.toString 0) + | n => f (n-1) ^ itemi (Int.toString n) + in + f (params - 1) + end + val args = paramRepeat (fn p => "uw_Basis_string p" ^ p) ", " + val decls = paramRepeat (fn p => "uw_Basis_string param" ^ i ^ "_" ^ p ^ " = NULL;") "\n" + val sets = paramRepeat (fn p => "param" ^ i ^ "_" ^ p + ^ " = strdup(p" ^ p ^ ");") "\n" + val frees = paramRepeat (fn p => "free(param" ^ i ^ "_" ^ p ^ ");") "\n" + val eqs = paramRepeat (fn p => "strcmp(param" ^ i ^ "_" ^ p + ^ ", p" ^ p ^ ")") " || " in box [string "static char *cache", string i, string " = NULL;", newline, - string "static uw_Basis_bool uw_Cache_check", - string i, - string "(uw_context ctx) { puts(\"SQLCACHE: checked ", + string decls, + newline, + string "static uw_Basis_string uw_Sqlcache_check", string i, - string ".\"); if (cache", + string "(uw_context ctx, ", + string args, + string ") {\n puts(\"SQLCACHE: checked ", string i, - string " == NULL) { uw_recordingStart(ctx); return uw_Basis_False; } else { uw_write(ctx, cache", + string ".\");\n if (cache", string i, - string "); puts(\"SQLCACHE: used ", + (* ASK: is returning the pointer okay? Should we duplicate? *) + string " == NULL || ", + string eqs, + string ") {\n puts(\"miss D:\"); puts(p0);\n return NULL;\n } else {\n puts(\"hit :D\");\n return cache", string i, - string ".\"); return uw_Basis_True; } };", + string ";\n } };", newline, - string "static uw_unit uw_Cache_store", + string "static uw_unit uw_Sqlcache_store", string i, - string "(uw_context ctx) { cache", + string "(uw_context ctx, uw_Basis_string s, ", + string args, + string ") {\n free(cache", string i, - string " = uw_recordingRead(ctx); puts(\"SQLCACHE: stored ", + string ");", + newline, + string frees, + newline, + string "cache", string i, - string ".\"); return uw_unit_v; };", + string " = strdup(s);", + newline, + string sets, newline, - string "static uw_unit uw_Cache_flush", + string "puts(\"SQLCACHE: stored ", string i, - string "(uw_context ctx) { free(cache", + string ".\"); puts(p0);\n return uw_unit_v;\n };", + newline, + string "static uw_unit uw_Sqlcache_flush", string i, - string "); cache", + string "(uw_context ctx) {\n free(cache", string i, - string " = NULL; puts(\"SQLCACHE: flushed ", + string ");\n cache", string i, - string ".\"); return uw_unit_v; };", - newline, - string "static uw_unit uw_Cache_ready", + string " = NULL;\n puts(\"SQLCACHE: flushed ", string i, - string "(uw_context ctx) { return uw_unit_v; };", + string ".\");\n return uw_unit_v;\n };", newline, newline] end) - (!Sqlcache.ffiIndices)), + (Sqlcache.getFfiInfo ())), newline, p_list_sep newline (fn x => x) pds, diff --git a/src/compiler.sig b/src/compiler.sig index fb0245ea..c154240a 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -199,7 +199,6 @@ signature COMPILER = sig val enableBoot : unit -> unit val doIflow : bool ref - val doSqlcache : bool ref val addPath : string * string -> unit val addModuleRoot : string * string -> unit diff --git a/src/compiler.sml b/src/compiler.sml index d7ee8700..fc4067a4 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -83,7 +83,6 @@ type ('src, 'dst) transform = { val debug = ref false val dumpSource = ref false val doIflow = ref false -val doSqlcache = ref false val doDumpSource = ref (fn () => ()) @@ -1457,7 +1456,10 @@ val sigcheck = { val toSigcheck = transform sigcheck "sigcheck" o toSidecheck val sqlcache = { - func = (fn file => (if !doSqlcache then Sqlcache.go file else file)), + func = (fn file => + if Settings.getSqlcache () + then let val file = MonoInline.inlineFull file in Sqlcache.go file end + else file), print = MonoPrint.p_file MonoEnv.empty } diff --git a/src/monoize.sig b/src/monoize.sig index 838d7c4c..951db01b 100644 --- a/src/monoize.sig +++ b/src/monoize.sig @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN diff --git a/src/monoize.sml b/src/monoize.sml index 6073a21f..d609a67d 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1957,20 +1957,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun (un, state), loc)), loc)), loc) - val body' = (L'.EApp ( + val body'' = (L'.EApp ( (L'.EApp ( (L'.EApp ((L'.ERel 4, loc), (L'.ERel 1, loc)), loc), (L'.ERel 0, loc)), loc), (L'.ERecord [], loc)), loc) - - val body = (L'.EQuery {exps = exps, - tables = tables, - state = state, - query = (L'.ERel 3, loc), - body = body', - initial = (L'.ERel 1, loc)}, - loc) + val body' = (L'.EQuery {exps = exps, + tables = tables, + state = state, + query = (L'.ERel 3, loc), + body = body'', + initial = (L'.ERel 1, loc)}, + loc) + val (body, fm) = if Settings.getSqlcache () then + let + val (urlifiedRel0, fm) = urlifyExp env fm ((L'.ERel 0, loc), state) + in + (Sqlcache.instrumentQuery (body', urlifiedRel0), fm) + end + else (body', fm) in ((L'.EAbs ("q", s, (L'.TFun (ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc)), loc), (L'.EAbs ("f", ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc), diff --git a/src/multimap_fn.sml b/src/multimap_fn.sml index 585b741f..3dab68a5 100644 --- a/src/multimap_fn.sml +++ b/src/multimap_fn.sml @@ -1,14 +1,16 @@ functor MultimapFn (structure KeyMap : ORD_MAP structure ValSet : ORD_SET) = struct type key = KeyMap.Key.ord_key type item = ValSet.item - type items = ValSet.set + type itemSet = ValSet.set type multimap = ValSet.set KeyMap.map - fun inserts (kToVs : multimap, k : key, vs : items) : multimap = + val empty : multimap = KeyMap.empty + fun insertSet (kToVs : multimap, k : key, vs : itemSet) : multimap = KeyMap.unionWith ValSet.union (kToVs, KeyMap.singleton (k, vs)) fun insert (kToVs : multimap, k : key, v : item) : multimap = - inserts (kToVs, k, ValSet.singleton v) - fun find (kToVs : multimap, k : key) = + insertSet (kToVs, k, ValSet.singleton v) + fun findSet (kToVs : multimap, k : key) = case KeyMap.find (kToVs, k) of SOME vs => vs | NONE => ValSet.empty + val findList : multimap * key -> item list = ValSet.listItems o findSet end diff --git a/src/settings.sig b/src/settings.sig index 9b32e502..e94832e0 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -279,6 +279,9 @@ signature SETTINGS = sig val setLessSafeFfi : bool -> unit val getLessSafeFfi : unit -> bool + val setSqlcache : bool -> unit + val getSqlcache : unit -> bool + val setFilePath : string -> unit (* Sets the directory where we look for files being added below. *) diff --git a/src/settings.sml b/src/settings.sml index eb350c95..81c33c08 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -744,6 +744,10 @@ val less = ref false fun setLessSafeFfi b = less := b fun getLessSafeFfi () = !less +val sqlcache = ref false +fun setSqlcache b = sqlcache := b +fun getSqlcache () = !sqlcache + structure SM = BinaryMapFn(struct type ord_key = string val compare = String.compare diff --git a/src/sources b/src/sources index 8860b310..518b7484 100644 --- a/src/sources +++ b/src/sources @@ -212,6 +212,8 @@ $(SRC)/multimap_fn.sml $(SRC)/sqlcache.sig $(SRC)/sqlcache.sml +$(SRC)/mono_inline.sml + $(SRC)/cjr.sml $(SRC)/postgres.sig diff --git a/src/sql.sig b/src/sql.sig index 2623f5e7..2aba8383 100644 --- a/src/sql.sig +++ b/src/sql.sig @@ -2,6 +2,8 @@ signature SQL = sig val debug : bool ref +val sqlcacheMode : bool ref + type lvar = int datatype func = diff --git a/src/sql.sml b/src/sql.sml index 8d245660..d38de055 100644 --- a/src/sql.sml +++ b/src/sql.sml @@ -270,6 +270,22 @@ fun sqlify chs = | _ => NONE +fun sqlifySqlcache chs = + case chs of + (* Match entire FFI application, not just its argument. *) + Exp (e' as EFfiApp ("Basis", f, [(_, _)]), _) :: chs => + if String.isPrefix "sqlify" f then + SOME ((e', ErrorMsg.dummySpan), chs) + else + NONE + | Exp (ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _), + (EPrim (Prim.String (Prim.Normal, "TRUE")), _)), + ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _), + (EPrim (Prim.String (Prim.Normal, "FALSE")), _))], _), _) :: chs => + SOME (e, chs) + + | _ => NONE + fun constK s = wrap (const s) (fn () => s) val funcName = altL [constK "COUNT", @@ -281,6 +297,8 @@ val funcName = altL [constK "COUNT", val unmodeled = altL [const "COUNT(*)", const "CURRENT_TIMESTAMP"] +val sqlcacheMode = ref false; + fun sqexp chs = log "sqexp" (altL [wrap prim SqConst, @@ -292,7 +310,7 @@ fun sqexp chs = wrap known SqKnown, wrap func SqFunc, wrap unmodeled (fn () => Unmodeled), - wrap sqlify Inj, + wrap (if !sqlcacheMode then sqlifySqlcache else sqlify) Inj, wrap (follow (const "COALESCE(") (follow sqexp (follow (const ",") (follow (keep (fn ch => ch <> #")")) (const ")"))))) (fn ((), (e, _)) => e), diff --git a/src/sqlcache.sml b/src/sqlcache.sml index b01de4c9..563b2162 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -1,21 +1,247 @@ -structure Sqlcache :> SQLCACHE = struct +structure Sqlcache (* :> SQLCACHE *) = struct open Sql open Mono structure IS = IntBinarySet structure IM = IntBinaryMap -structure StringKey = struct type ord_key = string val compare = String.compare end -structure SS = BinarySetFn (StringKey) -structure SM = BinaryMapFn (StringKey) -structure SIMM = MultimapFn (structure KeyMap = SM structure ValSet = IS) +structure SK = struct type ord_key = string val compare = String.compare end +structure SS = BinarySetFn(SK) +structure SM = BinaryMapFn(SK) +structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS) -val ffiIndices : int list ref = ref [] +(* Filled in by cacheWrap during Sqlcache. *) +val ffiInfo : {index : int, params : int} list ref = ref [] -(* Expression construction utilities. *) +fun getFfiInfo () = !ffiInfo + +(* Program analysis. *) + +val useInjIfPossible = + fn SqConst prim => Inj (EPrim (Prim.String (Prim.Normal, Prim.toString prim)), ErrorMsg.dummySpan) + | sqexp => sqexp + +fun equalities (canonicalTable : string -> string) : + sqexp -> ((string * string) * Mono.exp) list option = + let + val rec eqs = + fn Binop (Exps f, e1, e2) => + (* TODO: use a custom datatype in Exps instead of a function. *) + (case f (Var 1, Var 2) of + Reln (Eq, [Var 1, Var 2]) => + let + val (e1', e2') = (useInjIfPossible e1, useInjIfPossible e2) + in + case (e1', e2') of + (Field (t, f), Inj i) => SOME [((canonicalTable t, f), i)] + | (Inj i, Field (t, f)) => SOME [((canonicalTable t, f), i)] + | _ => NONE + end + | _ => NONE) + | Binop (Props f, e1, e2) => + (* TODO: use a custom datatype in Props instead of a function. *) + (case f (True, False) of + And (True, False) => + (case (eqs e1, eqs e2) of + (SOME eqs1, SOME eqs2) => SOME (eqs1 @ eqs2) + | _ => NONE) + | _ => NONE) + | _ => NONE + in + eqs + end + +val equalitiesQuery = + fn Query1 {From = tablePairs, Where = SOME exp, ...} => + equalities + (* If we have [SELECT ... FROM T AS T' ...], use T, not T'. *) + (fn t => + case List.find (fn (_, tAs) => t = tAs) tablePairs of + NONE => t + | SOME (tOrig, _) => tOrig) + exp + | Query1 {Where = NONE, ...} => SOME [] + | _ => NONE + +val equalitiesDml = + fn Insert (tab, eqs) => SOME (List.mapPartial + (fn (name, sqexp) => + case useInjIfPossible sqexp of + Inj e => SOME ((tab, name), e) + | _ => NONE) + eqs) + | Delete (tab, exp) => equalities (fn _ => tab) exp + (* TODO: examine the updated values and not just the way they're filtered. *) + (* For example, UPDATE foo SET Id = 9001 WHERE Id = 42 should update both the + Id = 42 and Id = 9001 cache entries. Could also think of it as doing a + Delete immediately followed by an Insert. *) + | Update (tab, _, exp) => equalities (fn _ => tab) exp + +val rec tablesQuery = + fn Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs) + | Union (q1, q2) => SS.union (tablesQuery q1, tablesQuery q2) + +val tableDml = + fn Insert (tab, _) => tab + | Delete (tab, _) => tab + | Update (tab, _, _) => tab + + +(* Program instrumentation. *) + +val stringTyp = (TFfi ("Basis", "string"), ErrorMsg.dummySpan) + +val sequence = + fn (exp :: exps) => + let + val loc = ErrorMsg.dummySpan + in + List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps + end + | _ => raise Match + +fun ffiAppCache' (func, index, args) : Mono.exp' = + EFfiApp ("Sqlcache", func ^ Int.toString index, args) + +fun ffiAppCache (func, index, args) : Mono. exp = + (ffiAppCache' (func, index, args), ErrorMsg.dummySpan) + +val varPrefix = "queryResult" + +fun indexOfName varName = + if String.isPrefix varPrefix varName + then Int.fromString (String.extract (varName, String.size varPrefix, NONE)) + else NONE + +val incRels = MonoUtil.Exp.map {typ = fn x => x, exp = fn ERel n => ERel (n + 1) | x => x} + +(* Filled in by instrumentQuery during Monoize, used during Sqlcache. *) +val urlifiedRel0s : Mono.exp IM.map ref = ref IM.empty + +(* Used by Monoize. *) +val instrumentQuery = + let + val nextQuery = ref 0 + fun iq (query, urlifiedRel0) = + case query of + (EQuery {state = typ, ...}, loc) => + let + val i = !nextQuery before nextQuery := !nextQuery + 1 + in + urlifiedRel0s := IM.insert (!urlifiedRel0s, i, urlifiedRel0); + (* ASK: name variables properly? *) + (ELet (varPrefix ^ Int.toString i, typ, query, + (* Uses a dummy FFI call to keep the urlified expression around, which + in turn keeps the declarations required for urlification safe from + MonoShake. The dummy call is removed during Sqlcache. *) + (* ASK: is there a better way? *) + (ESeq ((EFfiApp ("Sqlcache", "dummy", [(urlifiedRel0, stringTyp)]), loc), + (ERel 0, loc)), + loc)), + loc) + end + | _ => raise Match + in + iq + end + +val gunk : ((string * string) * Mono.exp) list list ref = ref [[]] + +fun cacheWrap (query, i, urlifiedRel0, eqs) = + case query of + (EQuery {state = typ, ...}, _) => + let + val loc = ErrorMsg.dummySpan + (* TODO: deal with effectful injected expressions. *) + val args = (ffiInfo := {index = i, params = length eqs} :: !ffiInfo; + map (fn (_, e) => (e, stringTyp)) eqs) before gunk := eqs :: !gunk + val argsInc = map (fn (e, t) => (incRels e, t)) args + in + (ECase (ffiAppCache ("check", i, args), + [((PNone stringTyp, loc), + (ELet ("q", typ, query, + (ESeq (ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argsInc), + (ERel 0, loc)), + loc)), + loc)), + ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc), + (* ASK: what does this bool do? *) + (EUnurlify ((ERel 0, loc), typ, false), loc))], + {disc = stringTyp, result = typ}), + loc) + end + | _ => raise Match + +fun fileMapfold doExp file start = + case MonoUtil.File.mapfold {typ = Search.return2, + exp = fn x => (fn s => Search.Continue (doExp x s)), + decl = Search.return2} file start of + Search.Continue x => x + | Search.Return _ => raise Match + +fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ()) + +val addChecking = + let + fun doExp queryInfo = + fn e' as ELet (v, t, queryExp as (EQuery {query = queryText, ...}, _), body) => + let + fun bind x f = Option.mapPartial f x + val attempt = + (* Ziv misses Haskell's do notation.... *) + bind (parse query queryText) (fn queryParsed => + (Print.preface ("gunk> ", (MonoPrint.p_exp MonoEnv.empty queryExp)); + bind (indexOfName v) (fn i => + bind (equalitiesQuery queryParsed) (fn eqs => + bind (IM.find (!urlifiedRel0s, i)) (fn urlifiedRel0 => + SOME (ELet (v, t, cacheWrap (queryExp, i, urlifiedRel0, eqs), body), + SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, i)) + queryInfo + (tablesQuery queryParsed))))))) + in + case attempt of + SOME pair => pair + | NONE => (e', queryInfo) + end + | ESeq ((EFfiApp ("Sqlcache", "dummy", _), _), (e', _)) => (e', queryInfo) + | e' => (e', queryInfo) + in + fn file => fileMapfold (fn exp => fn state => doExp state exp) file SIMM.empty + end + +fun addFlushing (file, queryInfo) = + let + val allIndices : int list = SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] queryInfo + fun flushes indices = map (fn i => ffiAppCache' ("flush", i, [])) indices + val doExp = + fn dmlExp as EDml (dmlText, _) => + let + val indices = + case parse dml dmlText of + SOME dmlParsed => SIMM.findList (queryInfo, tableDml dmlParsed) + | NONE => allIndices + in + sequence (flushes indices @ [dmlExp]) + end + | e' => e' + in + fileMap doExp file + end + +fun go file = + let + val () = Sql.sqlcacheMode := true + in + addFlushing (addChecking file) before Sql.sqlcacheMode := false + end + + +(* BEGIN OLD fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc) fun intTyp loc = (TFfi ("Basis", "int"), loc) +fun stringExp (s, loc) = (EPrim (Prim.String (Prim.Normal, s)), loc) + fun boolPat (b, loc) = (PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", arg = NONE, con = if b then "True" else "False"}, @@ -23,11 +249,13 @@ fun boolPat (b, loc) = (PCon (Enum, loc) fun boolTyp loc = (TFfi ("Basis", "int"), loc) -fun ffiAppExp (module, func, index, loc) = - (EFfiApp (module, func ^ Int.toString index, []), loc) +fun ffiAppExp (module, func, index, args, loc) = + (EFfiApp (module, func ^ Int.toString index, args), loc) -fun sequence ((exp :: exps), loc) = +val sequence = + fn ((exp :: exps), loc) => List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc)) exp exps + | _ => raise Match fun antiguardUnit (cond, exp, loc) = (ECase (cond, @@ -41,11 +269,10 @@ fun underAbs f (exp as (exp', loc)) = EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc) | _ => f exp -(* Program analysis and augmentation. *) val rec tablesRead = - fn Query1 {From=tablePairs, ...} => SS.fromList (map #1 tablePairs) - | Union (q1,q2) => SS.union (tablesRead q1, tablesRead q2) + fn Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs) + | Union (q1, q2) => SS.union (tablesRead q1, tablesRead q2) val tableWritten = fn Insert (tab, _) => tab @@ -57,7 +284,7 @@ fun tablesInExp' exp' = val nothing = {read = SS.empty, written = SS.empty} in case exp' of - EQuery {query=e, ...} => + EQuery {query = e, ...} => (case parse query e of SOME q => {read = tablesRead q, written = SS.empty} | NONE => nothing) @@ -71,8 +298,11 @@ fun tablesInExp' exp' = val tablesInExp = let fun addTables (exp', {read, written}) = - let val {read = r, written = w} = tablesInExp' exp' - in {read = SS.union (r, read), written = SS.union (w, written)} end + let + val {read = r, written = w} = tablesInExp' exp' + in + {read = SS.union (r, read), written = SS.union (w, written)} + end in MonoUtil.Exp.fold {typ = #2, exp = addTables} {read = SS.empty, written = SS.empty} @@ -150,7 +380,7 @@ fun fileFoldMapiSelected f init (file, indices) = in case MonoUtil.File.mapfold {typ = nada, exp = nada, decl = doDecl} file init of Search.Continue x => x - | _ => (file, init) (* Should never happen. *) + | _ => raise Match (* Should never happen. *) end fun fileMapSelected f = #1 o fileFoldMapiSelected (fn (_, x, _) => (f x, ())) () @@ -178,4 +408,6 @@ fun go file = addCacheFlushing (fileWithChecks, tablesToIndices, writers) end +END OLD *) + end -- cgit v1.2.3 From bfcd84434ee997b474935aa13ae7bc1f3801d795 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Thu, 19 Nov 2015 01:59:00 -0500 Subject: Support nested queries but disable UrFlow for now. --- caching-tests/test.ur | 71 ++++++----- caching-tests/test.urp | 4 +- caching-tests/test.urs | 7 +- src/compiler.sig | 4 +- src/compiler.sml | 4 +- src/sources | 3 - src/sql.sig | 13 ++- src/sql.sml | 86 +++++++++----- src/sqlcache.sml | 310 ++++++++++++++++++++++++++++++++++--------------- 9 files changed, 332 insertions(+), 170 deletions(-) (limited to 'src/compiler.sml') diff --git a/caching-tests/test.ur b/caching-tests/test.ur index cbfde556..ea64bb2d 100644 --- a/caching-tests/test.ur +++ b/caching-tests/test.ur @@ -1,9 +1,7 @@ table tab : {Id : int, Val : int, Foo : int} PRIMARY KEY Id fun cache id = - res <- oneOrNoRows (SELECT tab.Val - FROM tab - WHERE tab.Id = {[id]}); + res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]}); return cache {case res of @@ -11,21 +9,32 @@ fun cache id = | Some row => {[row.Tab.Val]}} -fun sillyRecursive {Id = id : int, FooBar = fooBar} = - if fooBar <= 0 - then 0 - else 1 + sillyRecursive {Id = id, FooBar = fooBar - 1} +(* fun cacheAlt id = *) +(* res <- oneOrNoRows (SELECT Q.Id *) +(* FROM (SELECT Tab.Id AS Id FROM tab WHERE Tab.Id = {[id]}) *) +(* AS Q); *) +(* return *) +(* cacheAlt *) +(* {case res of *) +(* None => ? *) +(* | Some row => {[row.Q.Id]}} *) +(* *) -fun cacheR (r : {Id : int, FooBar : int}) = - res <- oneOrNoRows (SELECT tab.Val - FROM tab - WHERE tab.Id = {[r.Id]}); - return - cacheR {[r.FooBar]} - {case res of - None => ? - | Some row => {[row.Tab.Val]}} - +(* fun sillyRecursive {Id = id : int, FooBar = fooBar} = *) +(* if fooBar <= 0 *) +(* then 0 *) +(* else 1 + sillyRecursive {Id = id, FooBar = fooBar - 1} *) + +(* fun cacheR (r : {Id : int, FooBar : int}) = *) +(* res <- oneOrNoRows (SELECT tab.Val *) +(* FROM tab *) +(* WHERE tab.Id = {[r.Id]}); *) +(* return *) +(* cacheR {[r.FooBar]} *) +(* {case res of *) +(* None => ? *) +(* | Some row => {[row.Tab.Val]}} *) +(* *) (* fun cache2 id v = *) (* res <- oneOrNoRows (SELECT tab.Val *) @@ -60,21 +69,21 @@ fun flush id = Changed {[id]}! -fun flash id = - dml (UPDATE tab - SET Foo = Val - WHERE Id = {[id]} OR Id = {[id - 1]} OR Id = {[id + 1]}); - return - Maybe changed {[id]}? - +(* fun flash id = *) +(* dml (UPDATE tab *) +(* SET Foo = Val *) +(* WHERE Id = {[id]} OR Id = {[id - 1]} OR Id = {[id + 1]}); *) +(* return *) +(* Maybe changed {[id]}? *) +(* *) -fun floosh id = - dml (UPDATE tab - SET Id = {[id + 1]} - WHERE Id = {[id]}); - return - Shifted {[id]}! - +(* fun floosh id = *) +(* dml (UPDATE tab *) +(* SET Id = {[id + 1]} *) +(* WHERE Id = {[id]} OR Id = {[id - 1]} OR Id = {[id + 1]}); *) +(* return *) +(* Shifted {[id]}! *) +(* *) (* val flush17 = *) (* dml (UPDATE tab *) diff --git a/caching-tests/test.urp b/caching-tests/test.urp index 07922e69..2cb9e711 100644 --- a/caching-tests/test.urp +++ b/caching-tests/test.urp @@ -1,8 +1,8 @@ database host=localhost sql test.sql safeGet Test/flush -safeGet Test/flash -safeGet Test/floosh +# safeGet Test/flash +# safeGet Test/floosh # safeGet Test/flush17 minHeap 4096 diff --git a/caching-tests/test.urs b/caching-tests/test.urs index 1fa5a9c2..d6e8dd2e 100644 --- a/caching-tests/test.urs +++ b/caching-tests/test.urs @@ -1,7 +1,8 @@ val cache : int -> transaction page -val cacheR : {Id : int, FooBar : int} -> transaction page +(* val cacheAlt : int -> transaction page *) +(* val cacheR : {Id : int, FooBar : int} -> transaction page *) (* val cache2 : int -> int -> transaction page *) val flush : int -> transaction page -val flash : int -> transaction page -val floosh : int -> transaction page +(* val flash : int -> transaction page *) +(* val floosh : int -> transaction page *) (* val flush17 : transaction page *) diff --git a/src/compiler.sig b/src/compiler.sig index c154240a..1ab0f7ae 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -114,7 +114,7 @@ signature COMPILER = sig val untangle : (Mono.file, Mono.file) phase val mono_reduce : (Mono.file, Mono.file) phase val mono_shake : (Mono.file, Mono.file) phase - val iflow : (Mono.file, Mono.file) phase + (* val iflow : (Mono.file, Mono.file) phase *) val namejs : (Mono.file, Mono.file) phase val scriptcheck : (Mono.file, Mono.file) phase val jscomp : (Mono.file, Mono.file) phase @@ -169,7 +169,7 @@ signature COMPILER = sig val toMono_reduce : (string, Mono.file) transform val toMono_shake : (string, Mono.file) transform val toMono_opt2 : (string, Mono.file) transform - val toIflow : (string, Mono.file) transform + (* val toIflow : (string, Mono.file) transform *) val toNamejs : (string, Mono.file) transform val toNamejs_untangle : (string, Mono.file) transform val toScriptcheck : (string, Mono.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 814c48d3..d91d02aa 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1372,19 +1372,21 @@ val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake +(* val iflow = { func = (fn file => (if !doIflow then Iflow.check file else (); file)), print = MonoPrint.p_file MonoEnv.empty } val toIflow = transform iflow "iflow" o toMono_opt2 +*) val namejs = { func = NameJS.rewrite, print = MonoPrint.p_file MonoEnv.empty } -val toNamejs = transform namejs "namejs" o toIflow +val toNamejs = transform namejs "namejs" o toMono_opt2 val toNamejs_untangle = transform untangle "namejs_untangle" o toNamejs diff --git a/src/sources b/src/sources index 8bf80bc6..1436575d 100644 --- a/src/sources +++ b/src/sources @@ -207,9 +207,6 @@ $(SRC)/mono_shake.sml $(SRC)/fuse.sig $(SRC)/fuse.sml -$(SRC)/iflow.sig -$(SRC)/iflow.sml - $(SRC)/name_js.sig $(SRC)/name_js.sml diff --git a/src/sql.sig b/src/sql.sig index 5f5d1b23..317c157f 100644 --- a/src/sql.sig +++ b/src/sql.sig @@ -81,12 +81,15 @@ datatype sitem = SqField of string * string | SqExp of sqexp * string -type query1 = {Select : sitem list, - From : (string * string) list, - Where : sqexp option} +datatype jtype = Inner | Left | Right | Full -datatype query = - Query1 of query1 +datatype fitem = + Table of string * string (* table AS name *) + | Join of jtype * fitem * fitem * sqexp + | Nested of query * string (* query AS name *) + + and query = + Query1 of {Select : sitem list, From : fitem list, Where : sqexp option} | Union of query * query val query : query parser diff --git a/src/sql.sml b/src/sql.sml index 08315a16..16d4210c 100644 --- a/src/sql.sml +++ b/src/sql.sml @@ -382,48 +382,72 @@ val select = log "select" (wrap (follow (const "SELECT ") (list sitem)) (fn ((), ls) => ls)) -val fitem = wrap (follow uw_ident - (follow (const " AS ") - t_ident)) - (fn (t, ((), f)) => (t, f)) +datatype jtype = Inner | Left | Right | Full -val from = log "from" - (wrap (follow (const "FROM ") (list fitem)) - (fn ((), ls) => ls)) +val jtype = wrap (ws (follow (opt (altL [wrap (const "LEFT") (fn () => Left), + wrap (const "RIGHT") (fn () => Right), + wrap (const "FULL") (fn () => Full)])) + (const " JOIN "))) + (fn (SOME jt, ()) => jt | (NONE, ()) => Inner) -val wher = wrap (follow (ws (const "WHERE ")) sqexp) - (fn ((), ls) => ls) - -type query1 = {Select : sitem list, - From : (string * string) list, - Where : sqexp option} - -val query1 = log "query1" - (wrap (follow (follow select from) (opt wher)) - (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher})) +datatype fitem = + Table of string * string (* table AS name *) + | Join of jtype * fitem * fitem * sqexp + | Nested of query * string (* query AS name *) -datatype query = - Query1 of query1 + and query = + Query1 of {Select : sitem list, From : fitem list, Where : sqexp option} | Union of query * query +val wher = wrap (follow (ws (const "WHERE ")) sqexp) + (fn ((), ls) => ls) + val orderby = log "orderby" (wrap (follow (ws (const "ORDER BY ")) (follow (list sqexp) (opt (ws (const "DESC"))))) ignore) -fun query chs = log "query" - (wrap - (follow - (alt (wrap (follow (const "((") - (follow query - (follow (const ") UNION (") - (follow query (const "))"))))) - (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2))) - (wrap query1 Query1)) - (opt orderby)) - #1) - chs +fun fitem chs = altL [wrap (follow uw_ident + (follow (const " AS ") + t_ident)) + (fn (t, ((), f)) => Table (t, f)), + wrap (follow (const "(") + (follow fitem + (follow jtype + (follow fitem + (follow (const " ON ") + (follow sqexp + (const ")"))))))) + (fn ((), (fi1, (jt, (fi2, ((), (se, ())))))) => + Join (jt, fi1, fi2, se)), + wrap (follow (const "(") + (follow query + (follow (const ") AS ") t_ident))) + (fn ((), (q, ((), f))) => Nested (q, f))] + chs + +and query1 chs = log "query1" + (wrap (follow (follow select from) (opt wher)) + (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher})) + chs + +and from chs = log "from" + (wrap (follow (const "FROM ") (list fitem)) + (fn ((), ls) => ls)) + chs + +and query chs = log "query" + (wrap (follow + (alt (wrap (follow (const "((") + (follow query + (follow (const ") UNION (") + (follow query (const "))"))))) + (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2))) + (wrap query1 Query1)) + (opt orderby)) + #1) + chs datatype dml = Insert of string * (string * sqexp) list diff --git a/src/sqlcache.sml b/src/sqlcache.sml index a8ef647b..9ff7c61d 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -30,11 +30,18 @@ fun mapFst f (x, y) = (f x, y) (* Option monad. *) fun obind (x, f) = Option.mapPartial f x -fun oguard (b, x) = if b then x else NONE +fun oguard (b, x) = if b then x () else NONE fun omap f = fn SOME x => SOME (f x) | _ => NONE fun omap2 f = fn (SOME x, SOME y) => SOME (f (x,y)) | _ => NONE fun osequence ys = List.foldr (omap2 op::) (SOME []) ys +fun concatMap f xs = List.concat (map f xs) + +val rec cartesianProduct : 'a list list -> 'a list list = + fn [] => [[]] + | (xs :: xss) => concatMap (fn ys => concatMap (fn x => [x :: ys]) xs) + (cartesianProduct xss) + fun indexOf test = let fun f n = @@ -104,10 +111,12 @@ val doBind = val dummyLoc = ErrorMsg.dummySpan (* DEBUG *) -fun printExp msg exp = Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_exp MonoEnv.empty exp) -fun printExp' msg exp' = printExp msg (exp', dummyLoc) -fun printTyp msg typ = Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_typ MonoEnv.empty typ) -fun printTyp' msg typ' = printTyp msg (typ', dummyLoc) +fun printExp msg exp = + (Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_exp MonoEnv.empty exp); exp) +fun printExp' msg exp' = (printExp msg (exp', dummyLoc); exp') +fun printTyp msg typ = + (Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_typ MonoEnv.empty typ); typ) +fun printTyp' msg typ' = (printTyp msg (typ', dummyLoc); typ') fun obindDebug printer (x, f) = case x of NONE => NONE @@ -204,13 +213,6 @@ datatype 'atom formula' = val flipJt = fn Conj => Disj | Disj => Conj -fun concatMap f xs = List.concat (map f xs) - -val rec cartesianProduct : 'a list list -> 'a list list = - fn [] => [[]] - | (xs :: xss) => concatMap (fn ys => concatMap (fn x => [x :: ys]) xs) - (cartesianProduct xss) - (* Pushes all negation to the atoms.*) fun pushNegate (normalizeAtom : bool * 'atom -> 'atom) (negating : bool) = fn Atom x => Atom' (normalizeAtom (negating, x)) @@ -349,8 +351,12 @@ end structure AtomOptionKey = OptionKeyFn(AtomExpKey) val rec tablesOfQuery = - fn Sql.Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs) + fn Sql.Query1 {From = fitems, ...} => List.foldl SS.union SS.empty (map tableOfFitem fitems) | Sql.Union (q1, q2) => SS.union (tablesOfQuery q1, tablesOfQuery q2) +and tableOfFitem = + fn Sql.Table (t, _) => SS.singleton t + | Sql.Nested (q, _) => tablesOfQuery q + | Sql.Join (_, f1, f2, _) => SS.union (tableOfFitem f1, tableOfFitem f2) val tableOfDml = fn Sql.Insert (tab, _) => tab @@ -489,43 +495,60 @@ end = struct (* Need lift', etc. because we don't have rank-2 polymorphism. This should probably use a functor (an ML one, not Haskell) but works for now. *) - fun traverseSqexp (pure, _, lift, _, lift'', lift2, _) f = + fun traverseSqexp (pure, _, _, _, lift, lift', _, _, lift2, _, _, _, _, _) f = let val rec tr = fn Sql.SqNot se => lift Sql.SqNot (tr se) | Sql.Binop (r, se1, se2) => lift2 (fn (trse1, trse2) => Sql.Binop (r, trse1, trse2)) (tr se1, tr se2) | Sql.SqKnown se => lift Sql.SqKnown (tr se) - | Sql.Inj (e', loc) => lift'' (fn fe' => Sql.Inj (fe', loc)) (f e') + | Sql.Inj (e', loc) => lift' (fn fe' => Sql.Inj (fe', loc)) (f e') | Sql.SqFunc (s, se) => lift (fn trse => Sql.SqFunc (s, trse)) (tr se) | se => pure se in tr end - fun traverseQuery (ops as (_, pure', _, lift', _, _, lift2')) f = + fun traverseFitem (ops as (_, _, _, pure''', _, _, _, lift''', _, _, _, _, lift2'''', lift2''''')) f = + let + val rec tr = + fn Sql.Table t => pure''' (Sql.Table t) + | Sql.Join (jt, fi1, fi2, se) => + lift2'''' (fn ((trfi1, trfi2), trse) => Sql.Join (jt, trfi1, trfi2, trse)) + (lift2''''' id (tr fi1, tr fi2), traverseSqexp ops f se) + | Sql.Nested (q, s) => lift''' (fn trq => Sql.Nested (trq, s)) + (traverseQuery ops f q) + in + tr + end + + and traverseQuery (ops as (_, pure', pure'', _, _, _, lift'', _, _, lift2', lift2'', lift2''', _, _)) f = let - val rec mp = + val rec seqList = + fn [] => pure'' [] + | (x::xs) => lift2''' op:: (x, seqList xs) + val rec tr = fn Sql.Query1 q => - (case #Where q of - NONE => pure' (Sql.Query1 q) - | SOME se => - lift' (fn mpse => Sql.Query1 {Select = #Select q, - From = #From q, - Where = SOME mpse}) - (traverseSqexp ops f se)) - | Sql.Union (q1, q2) => lift2' Sql.Union (mp q1, mp q2) + (* TODO: make sure we don't need to traverse [#Select q]. *) + lift2' (fn (trfrom, trwher) => Sql.Query1 {Select = #Select q, + From = trfrom, + Where = trwher}) + (seqList (map (traverseFitem ops f) (#From q)), + case #Where q of + NONE => pure' NONE + | SOME se => lift'' SOME (traverseSqexp ops f se)) + | Sql.Union (q1, q2) => lift2'' Sql.Union (tr q1, tr q2) in - mp + tr end (* Include unused tuple elements in argument for convenience of using same argument as [traverseQuery]. *) - fun traverseIM (pure, _, _, _, _, lift2, _) f = + fun traverseIM (pure, _, _, _, _, _, _, _, _, lift2, _, _, _, _) f = IM.foldli (fn (k, v, acc) => lift2 (fn (acc, w) => IM.insert (acc, k, w)) (acc, f (k,v))) (pure IM.empty) - fun traverseSubst (ops as (_, pure', lift, _, _, _, lift2')) f = + fun traverseSubst (ops as (_, pure', _, _, lift, _, _, _, _, lift2', _, _, _, _)) f = let fun mp ((n, fields), sqlify) = lift (fn ((n', fields'), sqlify') => @@ -546,11 +569,14 @@ end = struct traverseIM ops (fn (_, v) => mp v) end - fun monoidOps plus zero = (fn _ => zero, fn _ => zero, - fn _ => fn x => x, fn _ => fn x => x, fn _ => fn x => x, - fn _ => plus, fn _ => plus) + fun monoidOps plus zero = + (fn _ => zero, fn _ => zero, fn _ => zero, fn _ => zero, + fn _ => fn x => x, fn _ => fn x => x, fn _ => fn x => x, fn _ => fn x => x, + fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus) - val optionOps = (SOME, SOME, omap, omap, omap, omap2, omap2) + val optionOps = (SOME, SOME, SOME, SOME, + omap, omap, omap, omap, + omap2, omap2, omap2, omap2, omap2, omap2) fun foldMapQuery plus zero = traverseQuery (monoidOps plus zero) val omapQuery = traverseQuery optionOps @@ -727,7 +753,7 @@ val rec sqexpToFormula = | Sql.Null => raise Fail "Sqlcache: sqexpToFormula (Null)" fun mapSqexpFields f = - fn Sql.Field (t, v) => f (t, v) + fn Sql.Field (t, v) => f (t, v) | Sql.SqNot e => Sql.SqNot (mapSqexpFields f e) | Sql.Binop (r, e1, e2) => Sql.Binop (r, mapSqexpFields f e1, mapSqexpFields f e2) | Sql.SqKnown e => Sql.SqKnown (mapSqexpFields f e) @@ -744,12 +770,102 @@ fun renameTables tablePairs = mapSqexpFields (fn (t, f) => Sql.Field (rename t, f)) end -fun queryToFormula marker = - fn Sql.Query1 {Select = sitems, From = tablePairs, Where = wher} => +structure FlattenQuery = struct + + datatype substitution = RenameTable of string | SubstituteExp of Sql.sqexp SM.map + + fun applySubst substTable = + let + fun substitute (table, field) = + case SM.find (substTable, table) of + NONE => Sql.Field (table, field) + | SOME (RenameTable realTable) => Sql.Field (realTable, field) + | SOME (SubstituteExp substField) => + case SM.find (substField, field) of + NONE => raise Fail "Sqlcache: applySubst" + | SOME se => se + in + mapSqexpFields substitute + end + + fun addToSubst (substTable, table, substField) = + SM.insert (substTable, + table, + case substField of + RenameTable _ => substField + | SubstituteExp subst => SubstituteExp (SM.map (applySubst substTable) subst)) + + fun newSubst (t, s) = addToSubst (SM.empty, t, s) + + datatype sitem' = Named of Sql.sqexp * string | Unnamed of Sql.sqexp + + type queryFlat = {Select : sitem' list, Where : Sql.sqexp} + + val sitemsToSubst = + List.foldl (fn (Named (se, s), acc) => SM.insert (acc, s, se) + | (Unnamed _, _) => raise Fail "Sqlcache: sitemsToSubst") + SM.empty + + fun unionSubst (s1, s2) = SM.unionWith (fn _ => raise Fail "Sqlcache: unionSubst") (s1, s2) + + fun sqlAnd (se1, se2) = Sql.Binop (Sql.RLop Sql.And, se1, se2) + + val rec flattenFitem : Sql.fitem -> (Sql.sqexp * substitution SM.map) list = + fn Sql.Table (real, alias) => [(Sql.SqTrue, newSubst (alias, RenameTable real))] + | Sql.Nested (q, s) => + let + val qfs = flattenQuery q + in + map (fn (qf, subst) => + (#Where qf, addToSubst (subst, s, SubstituteExp (sitemsToSubst (#Select qf))))) + qfs + end + | Sql.Join (jt, fi1, fi2, se) => + concatMap (fn ((wher1, subst1)) => + map (fn (wher2, subst2) => + (sqlAnd (wher1, wher2), + (* There should be no name conflicts... Ziv hopes? *) + unionSubst (subst1, subst2))) + (flattenFitem fi2)) + (flattenFitem fi1) + + and flattenQuery : Sql.query -> (queryFlat * substitution SM.map) list = + fn Sql.Query1 q => + let + val fifss = cartesianProduct (map flattenFitem (#From q)) + in + map (fn fifs => + let + val subst = List.foldl (fn ((_, subst), acc) => unionSubst (acc, subst)) + SM.empty + fifs + val wher = List.foldr (fn ((wher, _), acc) => sqlAnd (wher, acc)) + (case #Where q of + NONE => Sql.SqTrue + | SOME wher => wher) + fifs + in + (* ASK: do we actually need to pass the substitution through here? *) + (* We use the substitution later, but it's not clear we + need any of its currently present fields again. *) + ({Select = map (fn Sql.SqExp (se, s) => Named (applySubst subst se, s) + | Sql.SqField tf => + Unnamed (applySubst subst (Sql.Field tf))) + (#Select q), + Where = applySubst subst wher}, + subst) + end) + fifss + end + | Sql.Union (q1, q2) => (flattenQuery q1) @ (flattenQuery q2) + +end + +val flattenQuery = map #1 o FlattenQuery.flattenQuery + +fun queryFlatToFormula marker {Select = sitems, Where = wher} = let - val fWhere = case wher of - NONE => Combo (Conj, []) - | SOME e => sqexpToFormula (renameTables tablePairs e) + val fWhere = sqexpToFormula wher in case marker of NONE => fWhere @@ -757,10 +873,10 @@ fun queryToFormula marker = let val fWhereMarked = mapFormulaExps markFields fWhere val toSqexp = - fn Sql.SqField tf => Sql.Field tf - | Sql.SqExp (se, _) => se + fn FlattenQuery.Named (se, _) => se + | FlattenQuery.Unnamed se => se fun ineq se = Atom (Sql.Ne, se, markFields se) - val fIneqs = Combo (Disj, map (ineq o renameTables tablePairs o toSqexp) sitems) + val fIneqs = Combo (Disj, map (ineq o toSqexp) sitems) in (Combo (Conj, [fWhere, @@ -769,7 +885,8 @@ fun queryToFormula marker = Combo (Conj, [fWhereMarked, fIneqs])])])) end end - | Sql.Union (q1, q2) => Combo (Disj, [queryToFormula marker q1, queryToFormula marker q2]) + +fun queryToFormula marker q = Combo (Disj, map (queryFlatToFormula marker) (flattenQuery q)) fun valsToFormula (markLeft, markRight) (table, vals) = Combo (Conj, @@ -828,7 +945,7 @@ structure ConflictMaps = struct (* If we don't know one side of the comparision, not a contradiction. *) | _ => false in - not (List.exists contradiction atoms) <\oguard\> SOME (UF.classes uf) + not (List.exists contradiction atoms) <\oguard\> (fn _ => SOME (UF.classes uf)) end fun addToEqs (eqs, n, e) = @@ -906,10 +1023,11 @@ structure ConflictMaps = struct mapFormula (toAtomExps DmlRel) (* No eqs should have key conflicts because no variable is in two - equivalence classes, so the [#1] could be [#2]. *) + equivalence classes. *) val mergeEqs : (atomExp IntBinaryMap.map option list -> atomExp IntBinaryMap.map option) = - List.foldr (omap2 (IM.unionWith #1)) (SOME IM.empty) + List.foldr (omap2 (IM.unionWith (fn _ => raise Fail "Sqlcache: ConflictMaps.mergeEqs"))) + (SOME IM.empty) val simplify = map TS.listItems @@ -1008,12 +1126,16 @@ fun fileAllMapfoldB doExp file start = fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ()) (* TODO: make this a bit prettier.... *) +(* TODO: factour out identical subexpressions to the same variable.... *) val simplifySql = let fun factorOutNontrivial text = let val loc = dummyLoc - fun strcat (e1, e2) = (EStrcat (e1, e2), loc) + val strcat = + fn (e1, (EPrim (Prim.String (Prim.Normal, "")), _)) => e1 + | ((EPrim (Prim.String (Prim.Normal, "")), _), e2) => e2 + | (e1, e2) => (EStrcat (e1, e2), loc) val chunks = Sql.chunkify text val (newText, newVariables) = (* Important that this is foldr (to oppose foldl below). *) @@ -1193,7 +1315,7 @@ fun shouldConsolidate args = end fun cacheExp (env, exp', invalInfo, state : state) = - case worthCaching exp' <\oguard\> typOfExp' env exp' of + case worthCaching exp' <\oguard\> (fn _ => typOfExp' env exp') of NONE => NONE | SOME (TFun _, _) => NONE | SOME typ => @@ -1202,26 +1324,28 @@ fun cacheExp (env, exp', invalInfo, state : state) = in shouldConsolidate args <\oguard\> - List.foldr (fn (arg, acc) => - acc - <\obind\> - (fn args' => - (case arg of - AsIs exp => SOME exp - | Urlify exp => - typOfExp env exp - <\obind\> - (fn typ => (MonoFooify.urlify env (exp, typ)))) - <\obind\> - (fn arg' => SOME (arg' :: args')))) - (SOME []) - args - <\obind\> - (fn args' => - cacheWrap (env, (exp', dummyLoc), typ, args', #index state) + (fn _ => + List.foldr (fn (arg, acc) => + acc + <\obind\> + (fn args' => + (case arg of + AsIs exp => SOME exp + | Urlify exp => + typOfExp env exp + <\obind\> + (fn typ => (MonoFooify.urlify env (exp, typ)))) + <\obind\> + (fn arg' => SOME (arg' :: args')))) + (SOME []) + args <\obind\> - (fn cachedExp => - SOME (cachedExp, InvalInfo.updateState (invalInfo, length args', state)))) + (fn args' => + cacheWrap (env, (exp', dummyLoc), typ, args', #index state) + <\obind\> + (fn cachedExp => + SOME (cachedExp, + InvalInfo.updateState (invalInfo, length args', state))))) end fun cacheQuery (effs, env, q) : subexp = @@ -1238,20 +1362,22 @@ fun cacheQuery (effs, env, q) : subexp = val {query = queryText, initial, body, ...} = q val attempt = (* Ziv misses Haskell's do notation.... *) - (safe 0 queryText andalso safe 0 initial andalso safe 2 body) + (safe 0 (printExp "attempt" queryText) andalso safe 0 initial andalso safe 2 body) <\oguard\> - Sql.parse Sql.query queryText - <\obind\> - (fn queryParsed => - let - val invalInfo = InvalInfo.singleton queryParsed - fun mkExp state = - case cacheExp (env, EQuery q, invalInfo, state) of - NONE => ((EQuery q, dummyLoc), state) - | SOME (cachedExp, state) => ((cachedExp, dummyLoc), state) - in - SOME (Cachable (invalInfo, mkExp)) - end) + (fn _ => + Sql.parse Sql.query (printExp "safe" queryText) + <\obind\> + (fn queryParsed => + let + val _ = (printExp "parsed" queryText) + val invalInfo = InvalInfo.singleton queryParsed + fun mkExp state = + case cacheExp (env, EQuery q, invalInfo, state) of + NONE => ((EQuery q, dummyLoc), state) + | SOME (cachedExp, state) => ((cachedExp, dummyLoc), state) + in + SOME (Cachable (invalInfo, mkExp)) + end)) in case attempt of NONE => Impure (EQuery q, dummyLoc) @@ -1279,16 +1405,16 @@ fun cacheTree (effs : IS.set) ((env, exp as (exp', loc)), state) = InvalInfo.unbind (invalInfoOfSubexp subexp, unbinds)) (subexps, args))) <\obind\> - (fn invalInfo => - SOME (Cachable (invalInfo, - fn state => - case cacheExp (env, - f (map (#2 o #1) args), - invalInfo, - state) of - NONE => mkExp state - | SOME (e', state) => ((e', loc), state)), - state)) + (fn invalInfo => + SOME (Cachable (invalInfo, + fn state => + case cacheExp (env, + f (map (#2 o #1) args), + invalInfo, + state) of + NONE => mkExp state + | SOME (e', state) => ((e', loc), state)), + state)) in case attempt of SOME (subexp, state) => (subexp, state) @@ -1384,7 +1510,7 @@ structure Invalidations = struct DmlRel n => ERel n | Prim p => EPrim p (* TODO: make new type containing only these two. *) - | _ => raise Fail "Sqlcache: optionAtomExpToExp", + | _ => raise Fail "Sqlcache: Invalidations.optionAtomExpToExp", loc)), loc) @@ -1506,8 +1632,8 @@ fun addLocking file = ListMergeSort.sort (fn ((i, _), (j, _)) => i > j) ls end fun locksOfName n = - lockList {store = IIMM.findSet (#flush lockMap, n), - flush =IIMM.findSet (#store lockMap, n)} + lockList {flush = IIMM.findSet (#flush lockMap, n), + store = IIMM.findSet (#store lockMap, n)} val locksOfExp = lockList o locksNeeded lockMap val expts = exports file fun doVal (v as (x, n, t, exp, s)) = -- cgit v1.2.3