ML half of initial prototype. (Doesn't compile because there's no C yet.)

6 files changed, 279 insertions, 84 deletions

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