From 013ea39e9f187efbb0e3a613264a1c7adfebe692 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Wed, 7 Oct 2015 08:58:08 -0400 Subject: Fix recording bugs to do with nesting and buffer reallocation. Stop MonoFooify printing spurious errors. --- src/c/urweb.c | 26 +++++++++---- src/lru_cache.sml | 3 +- src/mono_fooify.sml | 75 +++++++++++++++++++++--------------- src/sqlcache.sml | 107 +++++++++++++++++++++++++++++++--------------------- src/toy_cache.sml | 16 ++++++-- 5 files changed, 141 insertions(+), 86 deletions(-) (limited to 'src') 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 ".\");}", -- cgit v1.2.3