diff options
-rw-r--r-- | include/urweb/types_cpp.h | 1 | ||||
-rw-r--r-- | include/urweb/urweb_cpp.h | 3 | ||||
-rw-r--r-- | src/c/urweb.c | 14 | ||||
-rw-r--r-- | src/lru_cache.sml | 4 | ||||
-rw-r--r-- | src/mono_reduce.sml | 44 | ||||
-rw-r--r-- | src/monoize.sml | 43 | ||||
-rw-r--r-- | src/mysql.sml | 3 | ||||
-rw-r--r-- | src/postgres.sml | 3 | ||||
-rw-r--r-- | src/settings.sig | 3 | ||||
-rw-r--r-- | src/settings.sml | 6 | ||||
-rw-r--r-- | src/sources | 6 | ||||
-rw-r--r-- | src/sql.sml | 15 | ||||
-rw-r--r-- | src/sqlcache.sml | 14 | ||||
-rw-r--r-- | src/sqlite.sml | 3 |
14 files changed, 108 insertions, 54 deletions
diff --git a/include/urweb/types_cpp.h b/include/urweb/types_cpp.h index 77e4c611..7eb976d4 100644 --- a/include/urweb/types_cpp.h +++ b/include/urweb/types_cpp.h @@ -127,6 +127,7 @@ typedef struct { typedef struct uw_Sqlcache_Value { char *result; char *output; + char *scriptOutput; unsigned long timeValid; } uw_Sqlcache_Value; diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index 916fbbf9..feebdef3 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -81,6 +81,7 @@ void uw_write(struct uw_context *, const char*); // For caching. void uw_recordingStart(struct uw_context *); char *uw_recordingRead(struct uw_context *); +char *uw_recordingReadScript(struct uw_context *); uw_Basis_source uw_Basis_new_client_source(struct uw_context *, uw_Basis_string); uw_unit uw_Basis_set_client_source(struct uw_context *, uw_Basis_source, uw_Basis_string); @@ -222,6 +223,8 @@ void uw_clear_headers(struct uw_context *); int uw_has_contentLength(struct uw_context *); void uw_Basis_clear_page(struct uw_context *); +void uw_write_script(struct uw_context *, uw_Basis_string); + uw_Basis_string uw_Basis_get_cookie(struct uw_context *, uw_Basis_string c); uw_unit uw_Basis_set_cookie(struct uw_context *, uw_Basis_string prefix, uw_Basis_string c, uw_Basis_string v, uw_Basis_time *expires, uw_Basis_bool secure); uw_unit uw_Basis_clear_cookie(struct uw_context *, uw_Basis_string prefix, uw_Basis_string c); diff --git a/src/c/urweb.c b/src/c/urweb.c index 620893c0..51a122d0 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -505,7 +505,7 @@ struct uw_context { // Sqlcache. int numRecording, recordingCapacity; - int *recordingOffsets; + int *recordingOffsets, *scriptRecordingOffsets; uw_Sqlcache_Update *cacheUpdate; uw_Sqlcache_Update *cacheUpdateTail; uw_Sqlcache_Unlock *cacheUnlock; @@ -597,6 +597,7 @@ uw_context uw_init(int id, uw_loggers *lg) { ctx->numRecording = 0; ctx->recordingCapacity = 0; ctx->recordingOffsets = malloc(0); + ctx->scriptRecordingOffsets = malloc(0); ctx->cacheUpdate = NULL; ctx->cacheUpdateTail = NULL; @@ -670,6 +671,7 @@ void uw_free(uw_context ctx) { free(ctx->output_buffer); free(ctx->recordingOffsets); + free(ctx->scriptRecordingOffsets); free(ctx); } @@ -1757,13 +1759,20 @@ void uw_recordingStart(uw_context ctx) { if (ctx->numRecording == ctx->recordingCapacity) { ++ctx->recordingCapacity; ctx->recordingOffsets = realloc(ctx->recordingOffsets, sizeof(int) * ctx->recordingCapacity); + ctx->scriptRecordingOffsets = realloc(ctx->scriptRecordingOffsets, sizeof(int) * ctx->recordingCapacity); } ctx->recordingOffsets[ctx->numRecording] = ctx->page.front - ctx->page.start; + ctx->scriptRecordingOffsets[ctx->numRecording] = ctx->script.front - ctx->script.start; ++ctx->numRecording; } char *uw_recordingRead(uw_context ctx) { - char *recording = ctx->page.start + ctx->recordingOffsets[--ctx->numRecording]; + char *recording = ctx->page.start + ctx->recordingOffsets[ctx->numRecording-1]; + return strdup(recording); +} + +char *uw_recordingReadScript(uw_context ctx) { + char *recording = ctx->script.start + ctx->scriptRecordingOffsets[--ctx->numRecording]; return strdup(recording); } @@ -4587,6 +4596,7 @@ static void uw_Sqlcache_freeValue(uw_Sqlcache_Value *value) { if (value) { free(value->result); free(value->output); + free(value->scriptOutput); free(value); } } diff --git a/src/lru_cache.sml b/src/lru_cache.sml index 81000458..f582bf6f 100644 --- a/src/lru_cache.sml +++ b/src/lru_cache.sml @@ -116,6 +116,8 @@ fun setupQuery {index, params} = newline,*) string " uw_write(ctx, v->output);", newline, + string " uw_write_script(ctx, v->scriptOutput);", + newline, string " return v->result;", newline, string " } else {", @@ -148,6 +150,8 @@ fun setupQuery {index, params} = newline, string " v->output = uw_recordingRead(ctx);", newline, + string " v->scriptOutput = uw_recordingReadScript(ctx);", + newline, (*string (" puts(\"SQLCACHE: stored " ^ i ^ ".\");"), newline,*) string (" uw_Sqlcache_store(ctx, cache" ^ i ^ ", ks, v);"), diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 540d396b..5bcb6f57 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -44,6 +44,13 @@ structure SS = BinarySetFn(struct val compare = String.compare end) +structure SLS = BinarySetFn(struct + type ord_key = string list + val compare = Order.joinL String.compare + end) + + + fun simpleTypeImpure tsyms = U.Typ.exists (fn TFun _ => true | TDatatype (n, _) => IS.member (tsyms, n) @@ -602,28 +609,35 @@ fun reduce' (file : file) = ERecord _ => true | _ => false + fun prefixFrom i (e : exp) = + case #1 e of + ERel i' => if i' = i then SOME [] else NONE + | EField (e', s) => + (case prefixFrom i e' of + NONE => NONE + | SOME ss => SOME (ss @ [s])) + | _ => NONE + fun whichProj i (e : exp) = case #1 e of - EPrim _ => SOME SS.empty - | ERel i' => if i' = i then NONE else SOME SS.empty - | ENamed _ => SOME SS.empty - | ECon (_, _, NONE) => SOME SS.empty + EPrim _ => SOME SLS.empty + | ERel i' => if i' = i then NONE else SOME SLS.empty + | ENamed _ => SOME SLS.empty + | ECon (_, _, NONE) => SOME SLS.empty | ECon (_, _, SOME e') => whichProj i e' - | ENone _ => SOME SS.empty + | ENone _ => SOME SLS.empty | ESome (_, e') => whichProj i e' - | EFfi _ => SOME SS.empty + | EFfi _ => SOME SLS.empty | EFfiApp (_, _, es) => whichProjs i (map #1 es) | EApp (e1, e2) => whichProjs i [e1, e2] | EAbs (_, _, _, e) => whichProj (i + 1) e | EUnop (_, e1) => whichProj i e1 | EBinop (_, _, e1, e2) => whichProjs i [e1, e2] | ERecord xets => whichProjs i (map #2 xets) - | EField ((ERel i', _), s) => - if i' = i then - SOME (SS.singleton s) - else - SOME SS.empty - | EField (e1, _) => whichProj i e1 + | EField (e1, s) => + (case prefixFrom i e1 of + NONE => SOME SLS.empty + | SOME ss => SOME (SLS.singleton (ss @ [s]))) | ECase (e1, pes, _) => whichProjs' i ((0, e1) :: map (fn (p, e) => (patBinds p, e)) pes) @@ -656,12 +670,12 @@ fun reduce' (file : file) = and whichProjs' i es = case es of - [] => SOME SS.empty + [] => SOME SLS.empty | (n, e) :: es' => case (whichProj (i + n) e, whichProjs' i es') of (SOME m1, SOME m2) => - if SS.isEmpty (SS.intersection (m1, m2)) then - SOME (SS.union (m1, m2)) + if SLS.isEmpty (SLS.intersection (m1, m2)) then + SOME (SLS.union (m1, m2)) else NONE | _ => NONE diff --git a/src/monoize.sml b/src/monoize.sml index 6715290f..6979474e 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2326,24 +2326,31 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val body = case #1 arg1 of L.CApp ((L.CFfi ("Basis", "option"), _), _) => - (L'.ECase ((L'.ERel 2, loc), - [((L'.PPrim (Prim.String (Prim.Normal, "=")), loc), - strcat [str "((", - (L'.ERel 1, loc), - str " ", - (L'.ERel 2, loc), - str " ", - (L'.ERel 0, loc), - str ") OR ((", - (L'.ERel 1, loc), - str ") IS NULL AND (", - (L'.ERel 0, loc), - str ") IS NULL))"]), - ((L'.PVar ("_", s), loc), - default 1)], - {disc = s, - result = s}), loc) - | _ => default 0 + (L'.ECase ((L'.ERel 2, loc), + [((L'.PPrim (Prim.String (Prim.Normal, "=")), loc), + if #supportsIsDistinctFrom (Settings.currentDbms ()) then + strcat [str "((", + (L'.ERel 1, loc), + str " IS NOT DISTINCT FROM ", + (L'.ERel 0, loc), + str "))"] + else + strcat [str "((", + (L'.ERel 1, loc), + str " ", + (L'.ERel 2, loc), + str " ", + (L'.ERel 0, loc), + str ") OR ((", + (L'.ERel 1, loc), + str ") IS NULL AND (", + (L'.ERel 0, loc), + str ") IS NULL))"]), + ((L'.PVar ("_", s), loc), + default 1)], + {disc = s, + result = s}), loc) + | _ => default 0 in ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), diff --git a/src/mysql.sml b/src/mysql.sml index 692be0a2..539428f6 100644 --- a/src/mysql.sml +++ b/src/mysql.sml @@ -1608,6 +1608,7 @@ val () = addDbms {name = "mysql", falseString = "FALSE", onlyUnion = true, nestedRelops = false, - windowFunctions = false} + windowFunctions = false, + supportsIsDistinctFrom = true} end diff --git a/src/postgres.sml b/src/postgres.sml index 1c95f414..ddfe0ad6 100644 --- a/src/postgres.sml +++ b/src/postgres.sml @@ -1145,7 +1145,8 @@ val () = addDbms {name = "postgres", falseString = "FALSE", onlyUnion = false, nestedRelops = true, - windowFunctions = true} + windowFunctions = true, + supportsIsDistinctFrom = true} val () = setDbms "postgres" diff --git a/src/settings.sig b/src/settings.sig index c75f12a3..5b54ed44 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -213,7 +213,8 @@ signature SETTINGS = sig falseString : string, onlyUnion : bool, nestedRelops : bool, - windowFunctions : bool + windowFunctions : bool, + supportsIsDistinctFrom : bool } val addDbms : dbms -> unit diff --git a/src/settings.sml b/src/settings.sml index 38ea30fc..d689824e 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -621,7 +621,8 @@ type dbms = { falseString : string, onlyUnion : bool, nestedRelops : bool, - windowFunctions: bool + windowFunctions: bool, + supportsIsDistinctFrom : bool } val dbmses = ref ([] : dbms list) @@ -653,7 +654,8 @@ val curDb = ref ({name = "", falseString = "", onlyUnion = false, nestedRelops = false, - windowFunctions = false} : dbms) + windowFunctions = false, + supportsIsDistinctFrom = false} : dbms) fun addDbms v = dbmses := v :: !dbmses fun setDbms s = diff --git a/src/sources b/src/sources index 8bf80bc6..1a09e7e8 100644 --- a/src/sources +++ b/src/sources @@ -186,9 +186,6 @@ $(SRC)/cache.sml $(SRC)/toy_cache.sml $(SRC)/lru_cache.sml -$(SRC)/sqlcache.sig -$(SRC)/sqlcache.sml - $(SRC)/monoize.sig $(SRC)/monoize.sml @@ -210,6 +207,9 @@ $(SRC)/fuse.sml $(SRC)/iflow.sig $(SRC)/iflow.sml +$(SRC)/sqlcache.sig +$(SRC)/sqlcache.sml + $(SRC)/name_js.sig $(SRC)/name_js.sml diff --git a/src/sql.sml b/src/sql.sml index dfe2f968..409e205c 100644 --- a/src/sql.sml +++ b/src/sql.sml @@ -193,7 +193,7 @@ val uw_ident = wrapP ident (fn s => if String.isPrefix "uw_" s andalso size s >= SOME (str (Char.toUpper (String.sub (s, 3))) ^ String.extract (s, 4, NONE)) else - NONE) + SOME s) val field = wrap (follow (opt (follow t_ident (const "."))) uw_ident) @@ -221,6 +221,7 @@ datatype sqexp = fun cmp s r = wrap (const s) (fn () => RCmp r) val sqbrel = altL [cmp "=" Eq, + cmp "IS NOT DISTINCT FROM" Eq, cmp "<>" Ne, cmp "<=" Le, cmp "<" Lt, @@ -334,11 +335,12 @@ fun sqexp chs = (altL [wrap (if !sqlcacheMode then primSqlcache else prim) SqConst, wrap (const "TRUE") (fn () => SqTrue), wrap (const "FALSE") (fn () => SqFalse), + wrap (follow (const "NULL::") ident) (fn ((), _) => Null), wrap (const "NULL") (fn () => Null), - wrap field Field, - wrap uw_ident Computed, wrap known SqKnown, wrap func SqFunc, + wrap field Field, + wrap uw_ident Computed, wrap (arithmetic sqexp) (fn _ => Unmodeled), wrap unmodeled (fn () => Unmodeled), wrap (if !sqlcacheMode then sqlifySqlcache else sqlify) Inj, @@ -402,6 +404,11 @@ val orderby = log "orderby" (opt (ws (const "DESC")))))) ignore) +val groupby = log "groupby" + (wrap (follow (ws (const "GROUP BY ")) + (list sqexp)) + ignore) + val jtype = altL [wrap (const "JOIN") (fn () => Inner), wrap (const "LEFT JOIN") (fn () => Left), wrap (const "RIGHT JOIN") (fn () => Right), @@ -444,7 +451,7 @@ and query chs = log "query" (follow query (const "))"))))) (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2))) (wrap query1 Query1)) - (opt orderby)) + (follow (opt groupby) (opt orderby))) #1) chs diff --git a/src/sqlcache.sml b/src/sqlcache.sml index 75a17e48..83a264fd 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -1370,9 +1370,9 @@ fun cacheExp (env, exp', invalInfo, state : state) = (case arg of AsIs exp => SOME exp | Urlify exp => - typOfExp env exp + (typOfExp env exp) <\obind\> - (fn typ => (MonoFooify.urlify env (exp, typ)))) + (fn typ => MonoFooify.urlify env (exp, typ))) <\obind\> (fn arg' => SOME (arg' :: args')))) (SOME []) @@ -1588,18 +1588,19 @@ fun addFlushing ((file, {tableToIndices, indexToInvalInfo, ffiInfo, ...} : state val inval = case Sql.parse Sql.dml dmlText of SOME dmlParsed => - SOME (map (fn i => (case IM.find (indexToInvalInfo, i) of + SOME (map (fn i => case IM.find (indexToInvalInfo, i) of SOME invalInfo => (i, invalidations (invalInfo, dmlParsed)) (* TODO: fail more gracefully. *) (* This probably means invalidating everything.... *) - | NONE => raise Fail "Sqlcache: addFlushing (a)")) + | NONE => raise Fail "Sqlcache: addFlushing (a)") (SIMM.findList (tableToIndices, tableOfDml dmlParsed))) | NONE => NONE in case inval of (* TODO: fail more gracefully. *) - NONE => raise Fail "Sqlcache: addFlushing (b)" + NONE => (Print.preface ("DML", MonoPrint.p_exp MonoEnv.empty dmlText); + raise Fail "Sqlcache: addFlushing (b)") | SOME invs => sequence (flushes invs @ [dmlExp]) end | e' => e' @@ -1723,8 +1724,9 @@ fun go file = (* Important that this happens after [MonoFooify.urlify] calls! *) val fmDecls = MonoFooify.getNewFmDecls () val () = Sql.sqlcacheMode := false + val file = insertAfterDatatypes (file, rev fmDecls) in - insertAfterDatatypes (file, rev fmDecls) + MonoReduce.reduce file end end diff --git a/src/sqlite.sml b/src/sqlite.sml index a1095709..c7694cde 100644 --- a/src/sqlite.sml +++ b/src/sqlite.sml @@ -849,6 +849,7 @@ val () = addDbms {name = "sqlite", falseString = "0", onlyUnion = false, nestedRelops = false, - windowFunctions = false} + windowFunctions = false, + supportsIsDistinctFrom = true} end |