Pure caching sort of works.

6 files changed, 166 insertions, 76 deletions

diff --git a/src/mono_env.sig b/src/mono_env.sig
index 97d7d9ea..9805c0d1 100644
--- a/src/mono_env.sig
+++ b/src/mono_env.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
@@ -42,6 +42,8 @@ signature MONO_ENV = sig
     val pushERel : env -> string -> Mono.typ -> Mono.exp option -> env
     val lookupERel : env -> int -> string * Mono.typ * Mono.exp option
 
+    val typeContext : env -> Mono.typ list
+
     val pushENamed : env -> string -> int -> Mono.typ -> Mono.exp option -> string -> env
     val lookupENamed : env -> int -> string * Mono.typ * Mono.exp option * string
 
diff --git a/src/mono_env.sml b/src/mono_env.sml
index 7f9a6e62..8617425e 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.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
@@ -108,6 +108,8 @@ fun lookupERel (env : env) n =
     (List.nth (#relE env, n))
     handle Subscript => raise UnboundRel n
 
+fun typeContext (env : env) = map #2 (#relE env)
+
 fun pushENamed (env : env) x n t eo s =
     {datatypes = #datatypes env,
      constructors = #constructors env,
diff --git a/src/mono_fooify.sig b/src/mono_fooify.sig
index 9eb8038b..ef8f09c2 100644
--- a/src/mono_fooify.sig
+++ b/src/mono_fooify.sig
@@ -19,9 +19,6 @@ structure Fm : sig
     val decls : t -> Mono.decl list
 
     val freshName : t -> int * t
-
-    (* Set at the end of [Monoize]. *)
-    val canonical : t ref
 end
 
 (* General form used in [Monoize]. *)
@@ -32,7 +29,9 @@ val fooifyExp : foo_kind
                 -> Mono.exp * Mono.typ
                 -> Mono.exp * Fm.t
 
-(* Easy-to-use special case used in [Sqlcache]. *)
-val urlify : MonoEnv.env -> Mono.exp * Mono.typ -> Mono.exp
+(* Easy-to-use interface in [Sqlcache]. Uses [Fm.canonical]. *)
+val canonicalFm : Fm.t ref (* Set at the end of [Monoize]. *)
+val urlify : MonoEnv.env -> Mono.exp * Mono.typ -> Mono.exp option
+val getNewFmDecls : unit -> Mono.decl list
 
 end
diff --git a/src/mono_fooify.sml b/src/mono_fooify.sml
index d7cb9f59..2e32b248 100644
--- a/src/mono_fooify.sml
+++ b/src/mono_fooify.sml
@@ -1,4 +1,4 @@
-structure MonoFooify :> MONO_FOOIFY = struct
+structure MonoFooify (* :> MONO_FOOIFY *) = struct
 
 open Mono
 
@@ -112,9 +112,6 @@ fun lookupList (t as {count, map, listMap, decls}) k tp thunk =
           | SOME n' => (t, n')
     end
 
-(* Has to be set at the end of [Monoize]. *)
-val canonical = ref (empty 0 : t)
-
 end
 
 fun fk2s fk =
@@ -166,7 +163,12 @@ fun fooifyExp fk lookupENamed lookupDatatype =
               | _ =>
                 case t of
                     TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm)
-                  | TFfi (m, x) => ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)
+                  | TFfi (m, x) => (if Settings.mayClientToServer (m, x)
+                                    (* TODO: better error message. (Then again, user should never see this.) *)
+                                    then ()
+                                    else (E.errorAt loc "MonoFooify: can't pass type from client to server";
+                                          Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]);
+                                    ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm))
 
                   | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm)
                   | TRecord ((x, t) :: xts) =>
@@ -296,22 +298,38 @@ fun fooifyExp fk lookupENamed lookupDatatype =
         fooify
     end
 
+(* Has to be set at the end of [Monoize]. *)
+val canonicalFm = ref (Fm.empty 0 : Fm.t)
+
 fun urlify env expTyp =
+    if ErrorMsg.anyErrors ()
+    then ((* DEBUG *) print "already error"; NONE)
+    else
+        let
+            val (exp, fm) =
+                fooifyExp
+                    Url
+                    (fn n =>
+                        let
+                            val (_, t, _, s) = MonoEnv.lookupENamed env n
+                        in
+                            (t, s)
+                        end)
+                    (fn n => MonoEnv.lookupDatatype env n)
+                    (!canonicalFm)
+                    expTyp
+        in
+            if ErrorMsg.anyErrors ()
+            then ((* DEBUG *) print "why"; (ErrorMsg.resetErrors (); NONE))
+            else (canonicalFm := fm; SOME exp)
+        end
+
+fun getNewFmDecls () =
     let
-        val (exp, fm) =
-            fooifyExp
-                Url
-                (fn n =>
-                    let
-                        val (_, t, _, s) = MonoEnv.lookupENamed env n
-                    in
-                        (t, s)
-                    end)
-                (fn n => MonoEnv.lookupDatatype env n)
-                (!Fm.canonical)
-                expTyp
+        val fm = !canonicalFm
     in
-        Fm.canonical := fm;
-        exp
+        (* canonicalFm := Fm.enter fm; *)
+        Fm.decls fm
     end
+
 end
diff --git a/src/monoize.sml b/src/monoize.sml
index 8f6b298d..4208f594 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -4484,13 +4484,14 @@ fun monoize env file =
                                                       (L'.DDatatype (dts @ !pvarDefs), loc) :: Fm.decls fm @ ds
                                                     | _ =>
                                                       ds' @ Fm.decls fm @ (L'.DDatatype (!pvarDefs), loc) :: ds)))
-                                    (env, Fm.empty mname, []) file
+                                     (env, Fm.empty mname, []) file
+        val monoFile = (rev ds, [])
     in
         pvars := RM.empty;
         pvarDefs := [];
         pvarOldDefs := [];
-        Fm.canonical := fm;
-        (rev ds, [])
+        MonoFooify.canonicalFm := Fm.empty (MonoUtil.File.maxName monoFile);
+        monoFile
     end
 
 end
diff --git a/src/sqlcache.sml b/src/sqlcache.sml
index 6b4216ea..eaa94685 100644
--- a/src/sqlcache.sml
+++ b/src/sqlcache.sml
@@ -493,27 +493,34 @@ fun incRels inc =
          bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound}
         0
 
-fun cacheWrap (env, query, i, resultTyp, args) =
+fun cacheWrap (env, exp, resultTyp, args, i) =
     let
-        val () = ffiInfo := {index = i, params = length args} :: !ffiInfo
         val loc = dummyLoc
         val rel0 = (ERel 0, loc)
-        (* We ensure before this step that all arguments aren't effectful.
-           by turning them into local variables as needed. *)
-        val argsInc = map (incRels 1) args
-        val check = (check (i, args), dummyLoc)
-        val store = (store (i, argsInc, MonoFooify.urlify env (rel0, resultTyp)), dummyLoc)
     in
-        ECase (check,
-               [((PNone stringTyp, loc),
-                 (ELet (varName "q", resultTyp, query, (ESeq (store, rel0), loc)), loc)),
-                ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc),
-                 (* Boolean is false because we're not unurlifying from a cookie. *)
-                 (EUnurlify (rel0, resultTyp, false), loc))],
-               {disc = stringTyp, result = resultTyp})
+        case MonoFooify.urlify env (rel0, resultTyp) of
+            NONE => NONE
+          | SOME urlified =>
+            let
+                val () = ffiInfo := {index = i, params = length args} :: !ffiInfo
+                (* We ensure before this step that all arguments aren't effectful.
+               by turning them into local variables as needed. *)
+                val argsInc = map (incRels 1) args
+                val check = (check (i, args), loc)
+                val store = (store (i, argsInc, urlified), loc)
+            in
+                SOME (ECase
+                          (check,
+                           [((PNone stringTyp, loc),
+                             (ELet (varName "q", resultTyp, exp, (ESeq (store, rel0), loc)), loc)),
+                            ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc),
+                             (* Boolean is false because we're not unurlifying from a cookie. *)
+                             (EUnurlify (rel0, resultTyp, false), loc))],
+                           {disc = (TOption stringTyp, loc), result = resultTyp}))
+            end
     end
 
-fun fileMapfold doExp file start =
+fun fileMapfoldB doExp file start =
     case MonoUtil.File.mapfoldB
              {typ = Search.return2,
               exp = fn env => fn e' => fn s => Search.Continue (doExp env e' s),
@@ -523,7 +530,7 @@ fun fileMapfold doExp file start =
         Search.Continue x => x
       | Search.Return _ => raise Match
 
-fun fileMap doExp file = #1 (fileMapfold (fn _ => fn e => fn _ => (doExp e, ())) file ())
+fun fileMap doExp file = #1 (fileMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ())
 
 fun factorOutNontrivial text =
     let
@@ -561,6 +568,7 @@ fun factorOutNontrivial text =
 
 fun addChecking file =
     let
+        val effs = effectfulDecls file
         fun doExp env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) =
          fn e' as EQuery {query = origQueryText,
                           state = resultTyp,
@@ -582,7 +590,6 @@ fun addChecking file =
                 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc))
                 fun bind x f = Option.mapPartial f x
                 fun guard b x = if b then x else NONE
-                val effs = effectfulDecls file
                 (* We use dummyTyp here. I think this is okay because databases
                    don't store (effectful) functions, but perhaps there's some
                    pathalogical corner case missing.... *)
@@ -596,12 +603,13 @@ fun addChecking file =
                     (* Ziv misses Haskell's do notation.... *)
                     guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) (
                     bind (Sql.parse Sql.query queryText) (fn queryParsed =>
-                    SOME (wrapLets (cacheWrap (env, queryExp, index, resultTyp, args)),
+                    bind (cacheWrap (env, queryExp, resultTyp, args, index)) (fn cachedExp =>
+                    SOME (wrapLets cachedExp,
                           (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
                                     tableToIndices
                                     (tablesQuery queryParsed),
                            IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)),
-                           index + 1))))
+                           index + 1)))))
             in
                 case attempt of
                     SOME pair => pair
@@ -609,9 +617,10 @@ fun addChecking file =
             end
           | e' => (e', queryInfo)
     in
-        fileMapfold (fn env => fn exp => fn state => doExp env state exp)
-                    file
-                    (SIMM.empty, IM.empty, 0)
+        (fileMapfoldB (fn env => fn exp => fn state => doExp env state exp)
+                      file
+                      (SIMM.empty, IM.empty, 0),
+         effs)
     end
 
 structure Invalidations = struct
@@ -662,7 +671,7 @@ val invalidations = Invalidations.invalidations
 (* DEBUG *)
 val gunk : ((Sql.query * int) * Sql.dml) list ref = ref []
 
-fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) =
+fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) =
     let
         val flushes = List.concat o
                       map (fn (i, argss) => map (fn args => flush (i, args)) argss)
@@ -694,7 +703,7 @@ fun addFlushing (file, (tableToIndices, indexToQueryNumArgs, _)) =
     in
         (* DEBUG *)
         gunk := [];
-        fileMap doExp file
+        (fileMap doExp file, index, effs)
     end
 
 val inlineSql =
@@ -713,25 +722,11 @@ val inlineSql =
         fileMap doExp
     end
 
-fun go file =
-    let
-        (* TODO: do something nicer than [Sql] being in one of two modes. *)
-        val () = (resetFfiInfo (); Sql.sqlcacheMode := true)
-        val file' = addFlushing (addChecking (inlineSql file))
-        val () = Sql.sqlcacheMode := false
-    in
-        file'
-    end
-
 
 (**********************)
 (* Mono Type Checking *)
 (**********************)
 
-val typOfPrim =
- fn Prim.Int _ => TFfi ("Basis", "int")
-  | Prim.Float _ => TFfi ("Basis", "int")
-
 fun typOfExp' (env : MonoEnv.env) : exp' -> typ option =
  fn EPrim p => SOME (TFfi ("Basis", case p of
                                         Prim.Int _ => "int"
@@ -779,6 +774,7 @@ fun typOfExp' (env : MonoEnv.env) : exp' -> typ option =
   | ELet (s, t, e1, e2) => typOfExp (MonoEnv.pushERel env s t (SOME e1)) e2
   | EClosure _ => NONE
   | EUnurlify (_, t, _) => SOME t
+  | _ => NONE
 
 and typOfExp env (e', loc) = typOfExp' env e'
 
@@ -797,17 +793,35 @@ val expOfSubexp =
  fn Pure f => f ()
   | Impure e => e
 
-val makeCache : MonoEnv.env -> exp' -> exp' = fn _ => fn _ => raise Fail "TODO"
-
-fun pureCache (effs : IS.set) (env : MonoEnv.env) (exp as (exp', loc)) : subexp =
+fun makeCache (env, exp', index) =
+    case typOfExp' env exp' of
+        NONE => NONE
+      | SOME (TFun _, _) => NONE
+      | SOME typ =>
+        case ListUtil.foldri (fn (_, _, NONE) => NONE
+                               | (n, typ, SOME args) =>
+                                 case MonoFooify.urlify env ((ERel n, dummyLoc), typ) of
+                                     NONE => NONE
+                                   | SOME arg => SOME (arg :: args))
+                             (SOME [])
+                             (MonoEnv.typeContext env) of
+            NONE => NONE
+          | SOME args => cacheWrap (env, (exp', dummyLoc), typ, args, index)
+
+fun pureCache (effs : IS.set) ((env, exp as (exp', loc)), index) : subexp * int =
     let
         fun wrapBindN f (args : (MonoEnv.env * exp) list) =
             let
-                val subexps = map (fn (env, exp) => pureCache effs env exp) args
+                val (subexps, index) = ListUtil.foldlMap (pureCache effs) index args
+                fun mkExp () = (f (map expOfSubexp subexps), loc)
             in
                 if List.exists isImpure subexps
-                then Impure (f (map expOfSubexp subexps), loc)
-                else Pure (fn () => (makeCache env (f (map #2 args)), loc))
+                then (Impure (mkExp ()), index)
+                else (Pure (fn () => case makeCache (env, f (map #2 args), index) of
+                                         NONE => mkExp ()
+                                       | SOME e' => (e', loc)),
+                      (* Conservatively increment index. *)
+                      index + 1)
             end
         fun wrapBind1 f arg =
             wrapBindN (fn [arg] => f arg | _ => raise Match) [arg]
@@ -837,7 +851,8 @@ fun pureCache (effs : IS.set) (env : MonoEnv.env) (exp as (exp', loc)) : subexp
             wrapBindN (fn (e::es) =>
                           ECase (e,
                                  (ListPair.map (fn (e, (p, _)) => (p, e)) (es, cases)),
-                                 {disc = disc, result = result}))
+                                 {disc = disc, result = result})
+                        | _ => raise Match)
                       ((env, e) :: map (fn (p, e) => (MonoEnv.patBinds env p, e)) cases)
           | EStrcat (e1, e2) => wrap2 EStrcat (e1, e2)
           (* We record page writes, so they're cachable. *)
@@ -849,8 +864,61 @@ fun pureCache (effs : IS.set) (env : MonoEnv.env) (exp as (exp', loc)) : subexp
           (* ASK: | EClosure (n, es) => ? *)
           | EUnurlify (e, t, b) => wrap1 (fn e => EUnurlify (e, t, b)) e
           | _ => if effectful effs env exp
-                 then Impure exp
-                 else Pure (fn () => (makeCache env exp', loc))
+                 then (Impure exp, index)
+                 else (Pure (fn () => (case makeCache (env, exp', index) of
+                                           NONE => exp'
+                                         | SOME e' => e',
+                                       loc)),
+                       index + 1)
+    end
+
+fun addPure ((decls, sideInfo), index, effs) =
+    let
+        fun doVal ((x, n, t, exp, s), index) =
+            let
+                val (subexp, index) = pureCache effs ((MonoEnv.empty, exp), index)
+            in
+                ((x, n, t, expOfSubexp subexp, s), index)
+            end
+        fun doDecl' (decl', index) =
+            case decl' of
+                DVal v =>
+                let
+                    val (v, index) = (doVal (v, index))
+                in
+                    (DVal v, index)
+                end
+              | DValRec vs =>
+                let
+                    val (vs, index) = ListUtil.foldlMap doVal index vs
+                in
+                    (DValRec vs, index)
+                end
+              | _ => (decl', index)
+        fun doDecl ((decl', loc), index) =
+            let
+                val (decl', index) = doDecl' (decl', index)
+            in
+                ((decl', loc), index)
+            end
+        val decls = #1 (ListUtil.foldlMap doDecl index decls)
+        (* Important that this happens after the MonoFooify.urlify calls! *)
+        val fmDecls = MonoFooify.getNewFmDecls ()
+    in
+        print (Int.toString (length fmDecls));
+        (decls @ fmDecls, sideInfo)
+    end
+
+val go' = addPure o addFlushing o addChecking o inlineSql
+
+fun go file =
+    let
+        (* TODO: do something nicer than [Sql] being in one of two modes. *)
+        val () = (resetFfiInfo (); Sql.sqlcacheMode := true)
+        val file' = go' file
+        val () = Sql.sqlcacheMode := false
+    in
+        file'
     end
 
 end