summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Ziv Scully <ziv@mit.edu>2015-10-07 08:58:08 -0400
committerGravatar Ziv Scully <ziv@mit.edu>2015-10-07 08:58:08 -0400
commit013ea39e9f187efbb0e3a613264a1c7adfebe692 (patch)
tree601babdc734209052526b2710bfdf628119b5e59 /src
parent36cb6a55281f753774e491cce3178eb8c927983e (diff)
Fix recording bugs to do with nesting and buffer reallocation. Stop MonoFooify printing spurious errors.
Diffstat (limited to 'src')
-rw-r--r--src/c/urweb.c26
-rw-r--r--src/lru_cache.sml3
-rw-r--r--src/mono_fooify.sml75
-rw-r--r--src/sqlcache.sml107
-rw-r--r--src/toy_cache.sml16
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 ".\");}",