Fix recording bugs to do with nesting and buffer reallocation. Stop MonoFooify printing spurious errors.

5 files changed, 141 insertions, 86 deletions

diff --git a/src/c/urweb.c b/src/c/urweb.c
index 61742693..957f158c 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -72,6 +72,9 @@ void uw_buffer_free(uw_buffer *b) {
 
 void uw_buffer_reset(uw_buffer *b) {
   b->front = b->start;
+  if (b->front != b->back) {
+    *b->front = 0;
+  }
 }
 
 int uw_buffer_check(uw_buffer *b, size_t extra) {
@@ -486,7 +489,8 @@ struct uw_context {
   size_t output_buffer_size;
 
   // For caching.
-  char *recording;
+  int numRecording;
+  int recordingOffset;
 
   int remoteSock;
 };
@@ -572,7 +576,8 @@ uw_context uw_init(int id, uw_loggers *lg) {
   ctx->output_buffer = malloc(1);
   ctx->output_buffer_size = 1;
 
-  ctx->recording = 0;
+  ctx->numRecording = 0;
+  ctx->recordingOffset = 0;
 
   ctx->remoteSock = -1;
 
@@ -1689,11 +1694,18 @@ void uw_write(uw_context ctx, const char* s) {
 }
 
 void uw_recordingStart(uw_context ctx) {
-  ctx->recording = ctx->page.front;
+  if (ctx->numRecording++ == 0) {
+    ctx->recordingOffset = ctx->page.front - ctx->page.start;
+  }
 }
 
 char *uw_recordingRead(uw_context ctx) {
-  return strdup(ctx->recording);
+  // Only the outermost recorder can read unless the recording is empty.
+  char *recording = ctx->page.start + ctx->recordingOffset;
+  if (--ctx->numRecording > 0 && recording != ctx->page.front) {
+    return NULL;
+  }
+  return strdup(recording);
 }
 
 char *uw_Basis_attrifyInt(uw_context ctx, uw_Basis_int n) {
@@ -4543,7 +4555,7 @@ time_t uw_Sqlcache_timeMax(time_t x, time_t y) {
   return difftime(x, y) > 0 ? x : y;
 }
 
-void uw_Sqlcache_freeuw_Sqlcache_CacheValue(uw_Sqlcache_CacheValue *value) {
+void uw_Sqlcache_free(uw_Sqlcache_CacheValue *value) {
   if (value) {
     free(value->result);
     free(value->output);
@@ -4554,7 +4566,7 @@ void uw_Sqlcache_freeuw_Sqlcache_CacheValue(uw_Sqlcache_CacheValue *value) {
 void uw_Sqlcache_delete(uw_Sqlcache_Cache *cache, uw_Sqlcache_CacheEntry* entry) {
   //uw_Sqlcache_listUw_Sqlcache_Delete(cache->lru, entry);
   HASH_DELETE(hh, cache->table, entry);
-  uw_Sqlcache_freeuw_Sqlcache_CacheValue(entry->value);
+  uw_Sqlcache_free(entry->value);
   free(entry->key);
   free(entry);
 }
@@ -4595,7 +4607,7 @@ void uw_Sqlcache_storeHelper(uw_Sqlcache_Cache *cache, char **keys, uw_Sqlcache_
   entry->timeValid = timeNow;
   if (cache->height == 0) {
     //uw_Sqlcache_listAdd(cache->lru, entry);
-    uw_Sqlcache_freeuw_Sqlcache_CacheValue(entry->value);
+    uw_Sqlcache_free(entry->value);
     entry->value = value;
     //if (cache->lru->size > MAX_SIZE) {
       //uw_Sqlcache_delete(cache, cache->lru->first);
diff --git a/src/lru_cache.sml b/src/lru_cache.sml
index b8dfde5e..275c3061 100644
--- a/src/lru_cache.sml
+++ b/src/lru_cache.sml
@@ -91,7 +91,8 @@ fun setupQuery {index, params} =
              newline,
              string ("  uw_Sqlcache_CacheValue *v = uw_Sqlcache_check(cache" ^ i ^ ", ks);"),
              newline,
-             string "  if (v) {",
+             (* If the output is null, it means we had too much recursion, so it's a miss. *)
+             string "  if (v && v->output != NULL) {",
              newline,
              string ("    puts(\"SQLCACHE: hit " ^ i ^ ".\");"),
              newline,
diff --git a/src/mono_fooify.sml b/src/mono_fooify.sml
index b7d0b6c6..bbd34b15 100644
--- a/src/mono_fooify.sml
+++ b/src/mono_fooify.sml
@@ -127,9 +127,13 @@ fun capitalize s =
 
 structure E = ErrorMsg
 
+exception TypeMismatch of Fm.t * E.span
+exception CantPass of Fm.t * typ
+exception DontKnow of Fm.t * typ
+
 val dummyExp = (EPrim (Prim.Int 0), E.dummySpan)
 
-fun fooifyExp fk lookupENamed lookupDatatype =
+fun fooifyExpWithExceptions fk lookupENamed lookupDatatype =
     let
         fun fooify fm (e, tAll as (t, loc)) =
             case #1 e of
@@ -155,8 +159,7 @@ fun fooifyExp fk lookupENamed lookupDatatype =
                                                                    arg'), loc)), loc),
                                          fm)
                             end
-                          | _ => (E.errorAt loc "Type mismatch encoding attribute";
-                                  (e, fm))
+                          | _ => raise TypeMismatch (fm, loc)
                 in
                     attrify (args, ft, (EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
                 end
@@ -165,10 +168,8 @@ fun fooifyExp fk lookupENamed lookupDatatype =
                     TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), 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))
+                                    then ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)
+                                    else raise CantPass (fm, tAll))
 
                   | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm)
                   | TRecord ((x, t) :: xts) =>
@@ -291,38 +292,50 @@ fun fooifyExp fk lookupENamed lookupDatatype =
                         ((EApp ((ENamed n, loc), e), loc), fm)
                     end
 
-                  | _ => (E.errorAt loc "Don't know how to encode attribute/URL type";
-                          Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
-                          (dummyExp, fm))
+                  | _ => raise DontKnow (fm, tAll)
     in
         fooify
     end
 
+fun fooifyExp fk lookupENamed lookupDatatype fm exp =
+    fooifyExpWithExceptions fk lookupENamed lookupDatatype fm exp
+    handle TypeMismatch (fm, loc) =>
+           (E.errorAt loc "Type mismatch encoding attribute";
+            (dummyExp, fm))
+         | CantPass (fm, typ as (_, loc)) =>
+           (E.errorAt loc "MonoFooify: can't pass type from client to server";
+            Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)];
+            (dummyExp, fm))
+         | DontKnow (fm, typ as (_, loc)) =>
+           (E.errorAt loc "Don't know how to encode attribute/URL type";
+            Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)];
+            (dummyExp, fm))
+
+
 (* 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
+    let
+        val (exp, fm) =
+            fooifyExpWithExceptions
+                Url
+                (fn n =>
+                    let
+                        val (_, t, _, s) = MonoEnv.lookupENamed env n
+                    in
+                        (t, s)
+                    end)
+                (fn n => MonoEnv.lookupDatatype env n)
+                (!canonicalFm)
+                expTyp
+    in
+        canonicalFm := fm;
+        SOME exp
+    end
+    handle TypeMismatch _ => NONE
+         | CantPass _ => NONE
+         | DontKnow _ => NONE
 
 fun getNewFmDecls () =
     let
diff --git a/src/sqlcache.sml b/src/sqlcache.sml
index 4d4c7d36..dd851787 100644
--- a/src/sqlcache.sml
+++ b/src/sqlcache.sml
@@ -53,8 +53,9 @@ fun getCache () = !cache
 
 (* Used to have type context for local variables in MonoUtil functions. *)
 val doBind =
- fn (env, MonoUtil.Exp.RelE (s, t)) => MonoEnv.pushERel env s t NONE
-  | (env, _) => env
+ fn (env, MonoUtil.Exp.RelE (x, t)) => MonoEnv.pushERel env x t NONE
+  | (env, MonoUtil.Exp.NamedE (x, n, t, eo, s)) => MonoEnv.pushENamed env x n t eo s
+  | (env, MonoUtil.Exp.Datatype (x, n, cs)) => MonoEnv.pushDatatype env x n cs
 
 
 (*******************)
@@ -499,8 +500,6 @@ fun cacheWrap (env, exp, resultTyp, args, i) =
     let
         val loc = dummyLoc
         val rel0 = (ERel 0, loc)
-        (* DEBUG *)
-        val () = print (Int.toString i ^ "\n")
     in
         case MonoFooify.urlify env (rel0, resultTyp) of
             NONE => NONE
@@ -524,7 +523,42 @@ fun cacheWrap (env, exp, resultTyp, args, i) =
             end
     end
 
-fun fileMapfoldB doExp file start =
+fun fileTopLevelMapfoldB doTopLevelExp (decls, sideInfo) state =
+    let
+        fun doVal env ((x, n, t, exp, s), state) =
+            let
+                val (exp, state) = doTopLevelExp env exp state
+            in
+                ((x, n, t, exp, s), state)
+            end
+        fun doDecl' env (decl', state) =
+            case decl' of
+                DVal v =>
+                let
+                    val (v, state) = doVal env (v, state)
+                in
+                    (DVal v, state)
+                end
+              | DValRec vs =>
+                let
+                    val (vs, state) = ListUtil.foldlMap (doVal env) state vs
+                in
+                    (DValRec vs, state)
+                end
+              | _ => (decl', state)
+        fun doDecl (decl as (decl', loc), (env, state)) =
+            let
+                val env = MonoEnv.declBinds env decl
+                val (decl', state) = doDecl' env (decl', state)
+            in
+                ((decl', loc), (env, state))
+            end
+        val (decls, (_, state)) = (ListUtil.foldlMap doDecl (MonoEnv.empty, state) decls)
+    in
+        ((decls, sideInfo), state)
+    end
+
+fun fileAllMapfoldB doExp file start =
     case MonoUtil.File.mapfoldB
              {typ = Search.return2,
               exp = fn env => fn e' => fn s => Search.Continue (doExp env e' s),
@@ -534,7 +568,7 @@ fun fileMapfoldB doExp file start =
         Search.Continue x => x
       | Search.Return _ => raise Match
 
-fun fileMap doExp file = #1 (fileMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ())
+fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ())
 
 fun factorOutNontrivial text =
     let
@@ -623,7 +657,7 @@ fun addChecking file =
             end
           | e' => (e', queryInfo)
     in
-        (fileMapfoldB (fn env => fn exp => fn state => doExp env state exp)
+        (fileAllMapfoldB (fn env => fn exp => fn state => doExp env state exp)
                       file
                       (SIMM.empty, IM.empty, 0),
          effs)
@@ -675,8 +709,8 @@ end
 val invalidations = Invalidations.invalidations
 
 (* DEBUG *)
-val gunk : ((Sql.query * int) * Sql.dml) list ref = ref []
-val gunk' : exp list ref = ref []
+(* val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] *)
+(* val gunk' : exp list ref = ref [] *)
 
 fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) =
     let
@@ -686,19 +720,19 @@ fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) =
          fn EDml (origDmlText, failureMode) =>
             let
                 (* DEBUG *)
-                val () = gunk' := origDmlText :: !gunk'
+                (* val () = gunk' := origDmlText :: !gunk' *)
                 val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText
                 val dmlText = incRels numArgs newDmlText
                 val dmlExp = EDml (dmlText, failureMode)
                 (* DEBUG *)
-                val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty origDmlText))
+                (* val () = Print.preface ("SQLCACHE: ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) *)
                 val inval =
                     case Sql.parse Sql.dml dmlText of
                         SOME dmlParsed =>
                         SOME (map (fn i => (case IM.find (indexToQueryNumArgs, i) of
                                                 SOME queryNumArgs =>
                                                 (* DEBUG *)
-                                                (gunk := (queryNumArgs, dmlParsed) :: !gunk;
+                                                ((* gunk := (queryNumArgs, dmlParsed) :: !gunk; *)
                                                  (i, invalidations (queryNumArgs, dmlParsed)))
                                               (* TODO: fail more gracefully. *)
                                               | NONE => raise Match))
@@ -713,7 +747,7 @@ fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) =
           | e' => e'
     in
         (* DEBUG *)
-        gunk := [];
+        (* gunk := []; *)
         (fileMap doExp file, index, effs)
     end
 
@@ -957,52 +991,37 @@ fun pureCache (effs : IS.set) ((env, exp as (exp', loc)), index) : subexp * int
                        index + 1)
     end
 
-fun addPure ((decls, sideInfo), indexStart, effs) =
+fun addPure (file, indexStart, effs) =
     let
-        fun doVal env ((x, n, t, exp, s), index) =
+        fun doTopLevelExp env exp index =
             let
                 val (subexp, index) = pureCache effs ((env, exp), index)
             in
-                ((x, n, t, expOfSubexp subexp, s), index)
-            end
-        fun doDecl' env (decl', index) =
-            case decl' of
-                DVal v =>
-                let
-                    val (v, index) = doVal env (v, index)
-                in
-                    (DVal v, index)
-                end
-              | DValRec vs =>
-                let
-                    val (vs, index) = ListUtil.foldlMap (doVal env) index vs
-                in
-                    (DValRec vs, index)
-                end
-              | _ => (decl', index)
-        fun doDecl (decl as (decl', loc), (revDecls, env, index)) =
-            let
-                val env = MonoEnv.declBinds env decl
-                val (decl', index) = doDecl' env (decl', index)
-                (* Important that this happens after [MonoFooify.urlify] calls! *)
-                val fmDecls = MonoFooify.getNewFmDecls ()
-            in
-                ((decl', loc) :: (fmDecls @ revDecls), env, index)
+                (expOfSubexp subexp, index)
             end
     in
-        (rev (#1 (List.foldl doDecl ([], MonoEnv.empty, indexStart) decls)), sideInfo)
+        #1 (fileTopLevelMapfoldB doTopLevelExp file indexStart)
+    end
+
+fun insertAfterDatatypes ((decls, sideInfo), newDecls) =
+    let
+        val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls
+    in
+        (datatypes @ newDecls @ others, sideInfo)
     end
 
-val go' = addPure o addFlushing o addChecking (* DEBUG: add back [o inlineSql]. *)
+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 file = go' file
+        (* Important that this happens after [MonoFooify.urlify] calls! *)
+        val fmDecls = MonoFooify.getNewFmDecls ()
         val () = Sql.sqlcacheMode := false
     in
-        file'
+        insertAfterDatatypes (file, rev fmDecls)
     end
 
 end
diff --git a/src/toy_cache.sml b/src/toy_cache.sml
index 34a7a26f..cfde027b 100644
--- a/src/toy_cache.sml
+++ b/src/toy_cache.sml
@@ -95,7 +95,7 @@ fun setupQuery {index, params} =
              string args,
              string ") {",
              newline,
-             string "if (cacheQuery",
+             string "if (cacheWrite",
              string i,
              (* ASK: is returning the pointer okay? Should we duplicate? *)
              string " == NULL",
@@ -116,9 +116,11 @@ fun setupQuery {index, params} =
              string i,
              string ".\");",
              newline,
-             string "uw_write(ctx, cacheWrite",
+             string " if (cacheWrite",
              string i,
-             string ");",
+             string " != NULL) { uw_write(ctx, cacheWrite",
+             string i,
+             string "); }",
              newline,
              string "return cacheQuery",
              string i,
@@ -176,6 +178,14 @@ fun setupQuery {index, params} =
              string i,
              string " = NULL;",
              newline,
+             string "free(cacheWrite",
+             string i,
+             string ");",
+             newline,
+             string "cacheWrite",
+             string i,
+             string " = NULL;",
+             newline,
              string "puts(\"SQLCACHE: flush ",
              string i,
              string ".\");}",