aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorGravatar Ziv Scully <ziv@mit.edu>2014-03-25 02:04:06 -0400
committerGravatar Ziv Scully <ziv@mit.edu>2014-03-25 02:04:06 -0400
commit93d6de491838eb3607a12686bfdc250366aa60e4 (patch)
tree2da01b66e562296fe3720e6fcfdee0311bb7d077
parent0e1252d5a6330570df698df924a0554b688042e8 (diff)
ML half of initial prototype. (Doesn't compile because there's no C yet.)
Diffstat
-rw-r--r--caching-tests/test.ur81
-rw-r--r--caching-tests/test.urp6
-rw-r--r--caching-tests/test.urs6
-rw-r--r--src/compiler.sig4
-rw-r--r--src/compiler.sml8
-rw-r--r--src/multimap_fn.sml14
-rw-r--r--src/sql.sig79
-rw-r--r--src/sql.sml79
-rw-r--r--src/sql_cache.sml179
9 files changed, 372 insertions, 84 deletions
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
+ <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>
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-18 07:58:31 +0000