Mercurial > urweb

changeset 2262:34ad83d9b729

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix recording bugs to do with nesting and buffer reallocation. Stop MonoFooify printing spurious errors.
author Ziv Scully <ziv@mit.edu>
date Wed, 07 Oct 2015 08:58:08 -0400
parents f81f1930c5d6
children dfadb5effdc0
files src/c/urweb.c src/lru_cache.sml src/mono_fooify.sml src/sqlcache.sml src/toy_cache.sml
diffstat 5 files changed, 141 insertions(+), 86 deletions(-) [+]
line wrap: on
line diff
--- a/src/c/urweb.c	Wed Sep 30 00:33:52 2015 -0400
+++ b/src/c/urweb.c	Wed Oct 07 08:58:08 2015 -0400
@@ -72,6 +72,9 @@
 
 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 @@
   size_t output_buffer_size;
 
   // For caching.
-  char *recording;
+  int numRecording;
+  int recordingOffset;
 
   int remoteSock;
 };
@@ -572,7 +576,8 @@
   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_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 @@
   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_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 @@
   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);
--- a/src/lru_cache.sml	Wed Sep 30 00:33:52 2015 -0400
+++ b/src/lru_cache.sml	Wed Oct 07 08:58:08 2015 -0400
@@ -91,7 +91,8 @@
              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,
--- a/src/mono_fooify.sml	Wed Sep 30 00:33:52 2015 -0400
+++ b/src/mono_fooify.sml	Wed Oct 07 08:58:08 2015 -0400
@@ -127,9 +127,13 @@
 
 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 @@
                                                                    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 @@
                     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 @@
                         ((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
--- a/src/sqlcache.sml	Wed Sep 30 00:33:52 2015 -0400
+++ b/src/sqlcache.sml	Wed Oct 07 08:58:08 2015 -0400
@@ -53,8 +53,9 @@
 
 (* 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 @@
     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 @@
             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 @@
         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 @@
             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 @@
 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 @@
          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 @@
           | e' => e'
     in
         (* DEBUG *)
-        gunk := [];
+        (* gunk := []; *)
         (fileMap doExp file, index, effs)
     end
 
@@ -957,52 +991,37 @@
                        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
 
-val go' = addPure o addFlushing o addChecking (* DEBUG: add back [o inlineSql]. *)
+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 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
--- a/src/toy_cache.sml	Wed Sep 30 00:33:52 2015 -0400
+++ b/src/toy_cache.sml	Wed Oct 07 08:58:08 2015 -0400
@@ -95,7 +95,7 @@
              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 @@
              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 @@
              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 ".\");}",