Mercurial > urweb
changeset 2203:39faa4a037f4
ML half of initial prototype. (Doesn't compile because there's no C yet.)
| author | Ziv Scully <ziv@mit.edu> |
|---|---|
| date | Tue, 25 Mar 2014 02:04:06 -0400 |
| parents | 606af2c9b828 |
| children | 01c8aceac480 |
| files | caching-tests/test.ur caching-tests/test.urp caching-tests/test.urs src/compiler.sig src/compiler.sml src/multimap_fn.sml src/sql.sig src/sql.sml src/sql_cache.sml |
| diffstat | 9 files changed, 372 insertions(+), 84 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/caching-tests/test.ur Tue Mar 25 02:04:06 2014 -0400 @@ -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 + <xml> + <body> + Flushed 1! + </body> + </xml> + +fun flush10 () : transaction page= + dml (INSERT INTO foo10 (Id, Bar) VALUES (42, "baz")); + return + <xml> + <body> + Flushed 2! + </body> + </xml> + +fun flush11 () : transaction page= + dml (INSERT INTO foo01 (Id, Bar) VALUES (42, "baz")); + dml (INSERT INTO foo10 (Id, Bar) VALUES (42, "baz")); + return + <xml> + <body> + Flushed 1 and 2! + </body> + </xml> + +fun cache01 () : transaction page = + res <- oneOrNoRows (SELECT foo01.Id, foo01.Bar + FROM foo01 + WHERE foo01.Bar = "baz"); + return + <xml> + <body> + Reading 1. + {case res of + None => <xml></xml> + | Some row => <xml>{[row.Foo01.Bar]}</xml>} + </body> + </xml> + +fun cache10 () : transaction page = + res <- oneOrNoRows (SELECT foo10.Id, foo10.Bar + FROM foo10 + WHERE foo10.Bar = "baz"); + return + <xml> + <body> + Reading 2. + {case res of + None => <xml></xml> + | Some row => <xml>{[row.Foo10.Bar]}</xml>} + </body> + </xml> + +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 + <xml> + <body> + Reading 1 and 2. + {case res of + None => <xml></xml> + | Some row => <xml>{[row.Foo01.Bar]}</xml>} + {case bla of + None => <xml></xml> + | Some row => <xml>{[row.Foo10.Bar]}</xml>} + </body> + </xml>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/caching-tests/test.urp Tue Mar 25 02:04:06 2014 -0400 @@ -0,0 +1,6 @@ +database dbname=test +safeGet Test/flush01 +safeGet Test/flush10 +safeGet Test/flush11 + +test
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/caching-tests/test.urs Tue Mar 25 02:04:06 2014 -0400 @@ -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
--- a/src/compiler.sig Sat Mar 08 05:06:22 2014 -0500 +++ b/src/compiler.sig Tue Mar 25 02:04:06 2014 -0400 @@ -122,7 +122,7 @@ 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 @@ 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
--- a/src/compiler.sml Sat Mar 08 05:06:22 2014 -0500 +++ b/src/compiler.sml Tue Mar 25 02:04:06 2014 -0400 @@ -1438,19 +1438,19 @@ 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,
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/multimap_fn.sml Tue Mar 25 02:04:06 2014 -0400 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/sql.sig Tue Mar 25 02:04:06 2014 -0400 @@ -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
--- a/src/sql.sml Sat Mar 08 05:06:22 2014 -0500 +++ b/src/sql.sml Tue Mar 25 02:04:06 2014 -0400 @@ -2,7 +2,7 @@ open Mono -val debug = ref true (*false*) +val debug = ref false type lvar = int @@ -425,81 +425,4 @@ 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/sql_cache.sml Tue Mar 25 02:04:06 2014 -0400 @@ -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