Mostly finish effectfulness analysis.

6 files changed, 239 insertions, 48 deletions

diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 6427cf3d..c150631c 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -3394,6 +3394,7 @@ fun p_file env (ds, ps) =
              newline,
 
              (* For sqlcache. *)
+             (* TODO: also record between Cache.check and Cache.store. *)
              box (List.map
                       (fn {index, params} =>
                           let val i = Int.toString index
@@ -3412,7 +3413,11 @@ fun p_file env (ds, ps) =
                               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",
+                          in box [string "static char *cacheQuery",
+                                  string i,
+                                  string " = NULL;",
+                                  newline,
+                                  string "static char *cacheWrite",
                                   string i,
                                   string " = NULL;",
                                   newline,
@@ -3424,12 +3429,14 @@ fun p_file env (ds, ps) =
                                   string args,
                                   string ") {\n puts(\"SQLCACHE: checked ",
                                   string i,
-                                  string ".\");\n if (cache",
+                                  string ".\");\n if (cacheQuery",
                                   string i,
                                   (* 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 ") {\n puts(\"miss D:\");\n uw_recordingStart(ctx);\n return NULL;\n } else {\n puts(\"hit :D\");\n uw_write(ctx, cacheWrite",
+                                  string i,
+                                  string ");\n return cacheQuery",
                                   string i,
                                   string ";\n } };",
                                   newline,
@@ -3437,27 +3444,31 @@ fun p_file env (ds, ps) =
                                   string i,
                                   string "(uw_context ctx, uw_Basis_string s, ",
                                   string args,
-                                  string ") {\n free(cache",
+                                  string ") {\n free(cacheQuery",
+                                  string i,
+                                  string "); free(cacheWrite",
                                   string i,
                                   string ");",
                                   newline,
                                   string frees,
                                   newline,
-                                  string "cache",
+                                  string "cacheQuery",
+                                  string i,
+                                  string " = strdup(s); cacheWrite",
                                   string i,
-                                  string " = strdup(s);",
+                                  string " = uw_recordingRead(ctx);",
                                   newline,
                                   string sets,
                                   newline,
                                   string "puts(\"SQLCACHE: stored ",
                                   string i,
-                                  string ".\"); puts(p0);\n return uw_unit_v;\n };",
+                                  string ".\");\n return uw_unit_v;\n };",
                                   newline,
                                   string "static uw_unit uw_Sqlcache_flush",
                                   string i,
-                                  string "(uw_context ctx) {\n free(cache",
+                                  string "(uw_context ctx) {\n free(cacheQuery",
                                   string i,
-                                  string ");\n cache",
+                                  string ");\n cacheQuery",
                                   string i,
                                   string " = NULL;\n puts(\"SQLCACHE: flushed ",
                                   string i,
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index 5ecd7290..3ae968b0 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -47,7 +47,6 @@ fun oneRun args =
                   Elaborate.unifyMore := false;
                   Compiler.dumpSource := false;
                   Compiler.doIflow := false;
-                  Compiler.doSqlcache := false;
                   Demo.noEmacs := false;
                   Settings.setDebug false)
 
@@ -161,7 +160,7 @@ fun oneRun args =
                 (Compiler.doIflow := true;
                  doArgs rest)
               | "-sqlcache" :: rest =>
-                (Compiler.doSqlcache := true;
+                (Settings.setSqlcache true;
                  doArgs rest)
               | "-moduleOf" :: fname :: _ =>
                 (print (Compiler.moduleOf fname ^ "\n");
diff --git a/src/sources b/src/sources
index 518b7484..7ad60517 100644
--- a/src/sources
+++ b/src/sources
@@ -168,6 +168,14 @@ $(SRC)/mono_env.sml
 $(SRC)/mono_print.sig
 $(SRC)/mono_print.sml
 
+$(SRC)/sql.sig
+$(SRC)/sql.sml
+
+$(SRC)/multimap_fn.sml
+
+$(SRC)/sqlcache.sig
+$(SRC)/sqlcache.sml
+
 $(SRC)/monoize.sig
 $(SRC)/monoize.sml
 
@@ -186,9 +194,6 @@ $(SRC)/mono_shake.sml
 $(SRC)/fuse.sig
 $(SRC)/fuse.sml
 
-$(SRC)/sql.sig
-$(SRC)/sql.sml
-
 $(SRC)/iflow.sig
 $(SRC)/iflow.sml
 
@@ -207,11 +212,6 @@ $(SRC)/sidecheck.sml
 $(SRC)/sigcheck.sig
 $(SRC)/sigcheck.sml
 
-$(SRC)/multimap_fn.sml
-
-$(SRC)/sqlcache.sig
-$(SRC)/sqlcache.sml
-
 $(SRC)/mono_inline.sml
 
 $(SRC)/cjr.sml
diff --git a/src/sql.sig b/src/sql.sig
index 2aba8383..cf2ae14a 100644
--- a/src/sql.sig
+++ b/src/sql.sig
@@ -4,6 +4,12 @@ val debug : bool ref
 
 val sqlcacheMode : bool ref
 
+datatype chunk =
+         String of string
+       | Exp of Mono.exp
+
+val chunkify : Mono.exp -> chunk list
+
 type lvar = int
 
 datatype func =
diff --git a/src/sql.sml b/src/sql.sml
index d38de055..7cfed022 100644
--- a/src/sql.sml
+++ b/src/sql.sml
@@ -272,10 +272,12 @@ fun sqlify chs =
 
 fun sqlifySqlcache chs =
     case chs of
-        (* Match entire FFI application, not just its argument. *)
-        Exp (e' as EFfiApp ("Basis", f, [(_, _)]), _) :: chs =>
+      (* Could have variables as well as FFIs. *)
+        Exp (e as (ERel _, _)) :: chs => SOME (e, chs)
+      (* If it is an FFI, match the entire expression. *)
+      | Exp (e as (EFfiApp ("Basis", f, [(_, _)]), _)) :: chs =>
         if String.isPrefix "sqlify" f then
-            SOME ((e', ErrorMsg.dummySpan), chs)
+            SOME (e, chs)
         else
             NONE
       | Exp (ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _),
diff --git a/src/sqlcache.sml b/src/sqlcache.sml
index 563b2162..d3c21371 100644
--- a/src/sqlcache.sml
+++ b/src/sqlcache.sml
@@ -15,10 +15,127 @@ val ffiInfo : {index : int, params : int} list ref = ref []
 
 fun getFfiInfo () = !ffiInfo
 
-(* Program analysis. *)
+(* Some FFIs have writing as their only effect, which the caching records. *)
+val ffiEffectful =
+    let
+        val fs = SS.fromList ["htmlifyInt_w",
+                              "htmlifyFloat_w",
+                              "htmlifyString_w",
+                              "htmlifyBool_w",
+                              "htmlifyTime_w",
+                              "attrifyInt_w",
+                              "attrifyFloat_w",
+                              "attrifyString_w",
+                              "attrifyChar_w",
+                              "urlifyInt_w",
+                              "urlifyFloat_w",
+                              "urlifyString_w",
+                              "urlifyBool_w",
+                              "urlifyChannel_w"]
+    in
+        fn (m, f) => Settings.isEffectful (m, f)
+                     andalso not (m = "Basis" andalso SS.member (fs, f))
+    end
+
+
+(* Effect analysis. *)
+
+(* Makes an exception for EWrite (which is recorded when caching). *)
+fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : Mono.exp -> bool =
+    (* If result is true, expression is definitely effectful. If result is
+       false, then expression is definitely not effectful if effs is fully
+       populated. The intended pattern is to use this a number of times equal
+       to the number of declarations in a file, Bellman-Ford style. *)
+    (* TODO: make incrementing of bound less janky, probably by using MonoUtil
+       instead of all this. *)
+    let
+        (* DEBUG: remove printing when done. *)
+        fun tru msg = if doPrint then (print (msg ^ "\n"); true) else true
+        val rec eff' =
+         (* ASK: is there a better way? *)
+         fn EPrim _ => false
+          (* We don't know if local functions have effects when applied. *)
+          | ERel idx => if inFunction andalso idx >= bound
+                        then tru ("rel" ^ Int.toString idx) else false
+          | ENamed name => if IS.member (effs, name) then tru "named" else false
+          | ECon (_, _, NONE) => false
+          | ECon (_, _, SOME e) => eff e
+          | ENone _ => false
+          | ESome (_, e) => eff e
+          (* TODO: use FFI whitelist. *)
+          | EFfi (m, f) => if ffiEffectful (m, f) then tru "ffi" else false
+          | EFfiApp (m, f, _) => if ffiEffectful (m, f) then tru "ffiapp" else false
+          (* ASK: we're calling functions effectful if they have effects when
+             applied or if the function expressions themselves have effects.
+             Is that okay? *)
+          (* This is okay because the values we ultimately care about aren't
+             functions, and this is a conservative approximation, anyway. *)
+          | EApp (eFun, eArg) => effectful doPrint effs true bound eFun orelse eff eArg
+          | EAbs (_, _, _, e) => effectful doPrint effs inFunction (bound+1) e
+          | EUnop (_, e) => eff e
+          | EBinop (_, _, e1, e2) => eff e1 orelse eff e2
+          | ERecord xs => List.exists (fn (_, e, _) => eff e) xs
+          | EField (e, _) => eff e
+          (* If any case could be effectful, consider it effectful. *)
+          | ECase (e, xs, _) => eff e orelse List.exists (fn (_, e) => eff e) xs
+          | EStrcat (e1, e2) => eff e1 orelse eff e2
+          (* ASK: how should we treat these three? *)
+          | EError _ => tru "error"
+          | EReturnBlob _ => tru "blob"
+          | ERedirect _ => tru "redirect"
+          (* EWrite is a special exception because we record writes when caching. *)
+          | EWrite _ => false
+          | ESeq (e1, e2) => eff e1 orelse eff e2
+          (* TODO: keep context of which local variables aren't effectful? Only
+             makes a difference for function expressions, though. *)
+          | ELet (_, _, eBind, eBody) => eff eBind orelse
+                                         effectful doPrint effs inFunction (bound+1) eBody
+          | EClosure (_, es) => List.exists eff es
+          (* TODO: deal with EQuery. *)
+          | EQuery _ => tru "query"
+          | EDml _ => tru "dml"
+          | ENextval _ => tru "nextval"
+          | ESetval _ => tru "setval"
+          | EUnurlify (e, _, _) => eff e
+          (* ASK: how should we treat this? *)
+          | EJavaScript _ => tru "javascript"
+          (* ASK: these are all effectful, right? *)
+          | ESignalReturn _ => tru "signalreturn"
+          | ESignalBind _ => tru "signalbind"
+          | ESignalSource _ => tru "signalsource"
+          | EServerCall _ => tru "servercall"
+          | ERecv _ => tru "recv"
+          | ESleep _ => tru "sleep"
+          | ESpawn _ => tru "spawn"
+        and eff = fn (e', _) => eff' e'
+    in
+        eff
+    end
+
+(* TODO: test this. *)
+val effectfulMap =
+    let
+        fun doVal ((_, name, _, e, _), effMap) =
+            if effectful false effMap false 0 e
+            then IS.add (effMap, name)
+            else effMap
+        val doDecl =
+         fn (DVal v, effMap) => doVal (v, effMap)
+          (* Repeat the list of declarations a number of times equal to its size. *)
+          | (DValRec vs, effMap) =>
+            List.foldl doVal effMap (List.concat (List.map (fn _ => vs) vs))
+          (* ASK: any other cases? *)
+          | (_, effMap) => effMap
+    in
+        MonoUtil.File.fold {typ = #2, exp = #2, decl = doDecl} IS.empty
+    end
+
+
+(* SQL analysis. *)
 
 val useInjIfPossible =
- fn SqConst prim => Inj (EPrim (Prim.String (Prim.Normal, Prim.toString prim)), ErrorMsg.dummySpan)
+ fn SqConst prim => Inj (EPrim (Prim.String (Prim.Normal, Prim.toString prim)),
+                         ErrorMsg.dummySpan)
   | sqexp => sqexp
 
 fun equalities (canonicalTable : string -> string) :
@@ -89,6 +206,7 @@ val tableDml =
 
 (* Program instrumentation. *)
 
+fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), ErrorMsg.dummySpan)
 val stringTyp = (TFfi ("Basis", "string"), ErrorMsg.dummySpan)
 
 val sequence =
@@ -103,7 +221,7 @@ val sequence =
 fun ffiAppCache' (func, index, args) : Mono.exp' =
     EFfiApp ("Sqlcache", func ^ Int.toString index, args)
 
-fun ffiAppCache (func, index, args) : Mono. exp =
+fun ffiAppCache (func, index, args) : Mono.exp =
     (ffiAppCache' (func, index, args), ErrorMsg.dummySpan)
 
 val varPrefix = "queryResult"
@@ -113,7 +231,17 @@ fun indexOfName 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}
+(* Always increments negative indices because that's what we need later. *)
+fun incRelsBound bound inc =
+    MonoUtil.Exp.mapB
+        {typ = fn x => x,
+         exp = fn level =>
+                  (fn ERel n => ERel (if n >= level orelse n < 0 then n + inc else n)
+                    | x => x),
+         bind = fn (level, MonoUtil.Exp.RelE _) => level + 1 | (level, _) => level}
+        bound
+
+val incRels = incRelsBound 0
 
 (* Filled in by instrumentQuery during Monoize, used during Sqlcache. *)
 val urlifiedRel0s : Mono.exp IM.map ref = ref IM.empty
@@ -129,12 +257,11 @@ val instrumentQuery =
                     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? *)
+                           (* TODO: thread a Monoize.Fm.t through this module. *)
                            (ESeq ((EFfiApp ("Sqlcache", "dummy", [(urlifiedRel0, stringTyp)]), loc),
                                   (ERel 0, loc)),
                             loc)),
@@ -145,28 +272,26 @@ val instrumentQuery =
         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 () = ffiInfo := {index = i, params = length eqs} :: !ffiInfo
             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
+            (* We ensure before this step that all arguments aren't effectful.
+               by turning them into local variables as needed. *)
+            val args = map (fn (_, e) => (e, stringTyp)) eqs
+            val argsInc = map (fn (e, typ) => (incRels 1 e, typ)) args
+            val check = ffiAppCache ("check", i, args)
+            val store = ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argsInc)
+            val rel0 = (ERel 0, loc)
         in
-            (ECase (ffiAppCache ("check", i, args),
+            (ECase (check,
                     [((PNone stringTyp, loc),
-                      (ELet ("q", typ, query,
-                             (ESeq (ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argsInc),
-                                    (ERel 0, loc)),
-                              loc)),
-                       loc)),
+                      (ELet ("q", typ, query, (ESeq (store, rel0), loc)), loc)),
                      ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc),
-                      (* ASK: what does this bool do? *)
-                      (EUnurlify ((ERel 0, loc), typ, false), loc))],
+                      (* Boolean is false because we're not unurlifying from a cookie. *)
+                      (EUnurlify (rel0, typ, false), loc))],
                     {disc = stringTyp, result = typ}),
              loc)
         end
@@ -181,20 +306,66 @@ fun fileMapfold doExp file start =
 
 fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ())
 
-val addChecking =
+fun addChecking file =
     let
         fun doExp queryInfo =
-         fn e' as ELet (v, t, queryExp as (EQuery {query = queryText, ...}, _), body) =>
+         fn e' as ELet (v, t,
+                        queryExp' as (EQuery {query = origQueryText,
+                                              initial, body, state, tables, exps}, queryLoc),
+                        letBody) =>
             let
+                val loc = ErrorMsg.dummySpan
+                val chunks = chunkify origQueryText
+                fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
+                val (newQueryText, newVariables) =
+                    (* Important that this is foldr (to oppose foldl below). *)
+                    List.foldr
+                        (fn (chunk, (qText, newVars)) =>
+                            case chunk of
+                                Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
+                              | Exp (e as (ERel _, _)) => (strcat (e, qText), newVars)
+                              | Exp (e as (ENamed _, _)) => (strcat (e, qText), newVars)
+                              (* Head of newVars has lowest index. *)
+                              | Exp e =>
+                                let
+                                    val n = length newVars
+                                in
+                                    (* This is the (n + 1)th new variable, so
+                                       there are already n new variables bound,
+                                       so we increment indices by n. *)
+                                    (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
+                                end
+                              | String s => (strcat (stringExp s, qText), newVars))
+                        (stringExp "", [])
+                        chunks
+                fun wrapLets e' =
+                    (* Important that this is foldl (to oppose foldr above). *)
+                    List.foldl (fn (v, e') => ELet ("sqlArgz", stringTyp, v, (e', loc))) e' newVariables
+                (* Increment once for each new variable just made. *)
+                val queryExp = incRels (length newVariables)
+                                       (EQuery {query = newQueryText,
+                                                initial = initial,
+                                                body = body,
+                                                state = state,
+                                                tables = tables,
+                                                exps = exps},
+                                        queryLoc)
+                val (EQuery {query = queryText, ...}, _) = queryExp
+                (* val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText)); *)
                 fun bind x f = Option.mapPartial f x
+                fun guard b x = if b then x else NONE
+                (* DEBUG: set first boolean argument to true to turn on printing. *)
+                fun safe bound = not o effectful true (effectfulMap file) false bound
                 val attempt =
                     (* Ziv misses Haskell's do notation.... *)
+                    guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) (
                     bind (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),
+                    SOME (wrapLets (ELet (v, t,
+                                          cacheWrap (queryExp, i, urlifiedRel0, eqs),
+                                          incRelsBound 1 (length newVariables) letBody)),
                           SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, i))
                                    queryInfo
                                    (tablesQuery queryParsed)))))))
@@ -206,7 +377,7 @@ val addChecking =
           | ESeq ((EFfiApp ("Sqlcache", "dummy", _), _), (e', _)) => (e', queryInfo)
           | e' => (e', queryInfo)
     in
-        fn file => fileMapfold (fn exp => fn state => doExp state exp) file SIMM.empty
+        fileMapfold (fn exp => fn state => doExp state exp) file SIMM.empty
     end
 
 fun addFlushing (file, queryInfo) =
@@ -231,8 +402,10 @@ fun addFlushing (file, queryInfo) =
 fun go file =
     let
         val () = Sql.sqlcacheMode := true
+        val file' = addFlushing (addChecking file)
+        val () = Sql.sqlcacheMode := false
     in
-        addFlushing (addChecking file) before Sql.sqlcacheMode := false
+         file'
     end