summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/urweb/types_cpp.h1
-rw-r--r--include/urweb/urweb_cpp.h3
-rw-r--r--src/c/urweb.c14
-rw-r--r--src/lru_cache.sml4
-rw-r--r--src/mono_reduce.sml44
-rw-r--r--src/monoize.sml43
-rw-r--r--src/mysql.sml3
-rw-r--r--src/postgres.sml3
-rw-r--r--src/settings.sig3
-rw-r--r--src/settings.sml6
-rw-r--r--src/sources6
-rw-r--r--src/sql.sml15
-rw-r--r--src/sqlcache.sml14
-rw-r--r--src/sqlite.sml3
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-09 08:11:50 +0000