diff options
author | 2014-08-17 13:07:56 -0400 | |
---|---|---|
committer | 2014-08-17 13:07:56 -0400 | |
commit | e230d565f1f0604eee2c964dab5374d07c24ed6d (patch) | |
tree | e8dd9defb6693cf3a9e153494da978d2391854c2 | |
parent | 4e6800f06759329f892ca8f40fcf50186b3785e1 (diff) |
New phase: Dbmodecheck
-rw-r--r-- | include/urweb/urweb_cpp.h | 1 | ||||
-rw-r--r-- | src/c/urweb.c | 9 | ||||
-rw-r--r-- | src/cjr.sml | 3 | ||||
-rw-r--r-- | src/cjr_print.sml | 8 | ||||
-rw-r--r-- | src/cjrize.sml | 10 | ||||
-rw-r--r-- | src/compiler.sig | 1 | ||||
-rw-r--r-- | src/compiler.sml | 9 | ||||
-rw-r--r-- | src/dbmodecheck.sig | 32 | ||||
-rw-r--r-- | src/dbmodecheck.sml | 86 | ||||
-rw-r--r-- | src/mono.sml | 9 | ||||
-rw-r--r-- | src/scriptcheck.sml | 2 | ||||
-rw-r--r-- | src/sources | 3 |
12 files changed, 160 insertions, 13 deletions
diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index 72997a12..d83b2cbb 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -90,6 +90,7 @@ uw_Basis_string uw_Basis_maybe_onunload(struct uw_context *, uw_Basis_string); void uw_set_needs_push(struct uw_context *, int); void uw_set_needs_sig(struct uw_context *, int); void uw_set_could_write_db(struct uw_context *, int); +void uw_set_at_most_one_query(struct uw_context *, int); char *uw_Basis_htmlifyInt(struct uw_context *, uw_Basis_int); char *uw_Basis_htmlifyFloat(struct uw_context *, uw_Basis_float); diff --git a/src/c/urweb.c b/src/c/urweb.c index 43c73661..d7bc05e3 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -441,7 +441,7 @@ struct uw_context { const char *script_header; - int needs_push, needs_sig, could_write_db; + int needs_push, needs_sig, could_write_db, at_most_one_query; size_t n_deltas, used_deltas; delta *deltas; @@ -520,6 +520,7 @@ uw_context uw_init(int id, uw_loggers *lg) { ctx->needs_push = 0; ctx->needs_sig = 0; ctx->could_write_db = 1; + ctx->at_most_one_query = 0; ctx->source_count = 0; @@ -786,7 +787,7 @@ failure_kind uw_begin(uw_context ctx, char *path) { } void uw_ensure_transaction(uw_context ctx) { - if (!ctx->transaction_started) { + if (!ctx->transaction_started && !ctx->at_most_one_query) { if (ctx->app->db_begin(ctx, ctx->could_write_db)) uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN"); ctx->transaction_started = 1; @@ -1205,6 +1206,10 @@ void uw_set_could_write_db(uw_context ctx, int n) { ctx->could_write_db = n; } +void uw_set_at_most_one_query(uw_context ctx, int n) { + ctx->at_most_one_query = n; +} + static void uw_buffer_check_ctx(uw_context ctx, const char *kind, uw_buffer *b, size_t extra, const char *desc) { if (b->back - b->front < extra) { diff --git a/src/cjr.sml b/src/cjr.sml index 8cbabdcc..3742a06f 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -129,10 +129,11 @@ datatype decl' = withtype decl = decl' located datatype sidedness = datatype Mono.sidedness +datatype dbmode = datatype Mono.dbmode datatype effect = datatype Export.effect datatype export_kind = datatype Export.export_kind -type file = decl list * (export_kind * string * int * typ list * typ * sidedness * bool) list +type file = decl list * (export_kind * string * int * typ list * typ * sidedness * dbmode * bool) list end diff --git a/src/cjr_print.sml b/src/cjr_print.sml index a4cc8c54..0867f001 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2634,7 +2634,7 @@ fun p_file env (ds, ps) = end | _ => NONE - val fields = foldl (fn ((ek, _, _, ts, _, _, _), fields) => + val fields = foldl (fn ((ek, _, _, ts, _, _, _, _), fields) => case ek of Action eff => (case List.nth (ts, length ts - 2) of @@ -2956,7 +2956,7 @@ fun p_file env (ds, ps) = scripts (Settings.getScripts ()) end - fun p_page (ek, s, n, ts, ran, side, tellSig) = + fun p_page (ek, s, n, ts, ran, side, dbmode, tellSig) = let val (ts, defInputs, inputsVar, fields) = case ek of @@ -3106,6 +3106,10 @@ fun p_file env (ds, ps) = string (if couldWriteDb ek then "1" else "0"), string ");", newline, + string "uw_set_at_most_one_query(ctx, ", + string (case dbmode of OneQuery => "1" | _ => "0"), + string ");", + newline, string "uw_set_needs_push(ctx, ", string (case side of ServerAndPullAndPush => "1" diff --git a/src/cjrize.sml b/src/cjrize.sml index 6dc0299c..11174162 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -730,12 +730,14 @@ fun cjrize (ds, sideInfo) = end) ([], [], [], Sm.empty) ds - val sideInfo = foldl (fn ((n, mode), mp) => IM.insert (mp, n, mode)) IM.empty sideInfo + val sideInfo = foldl (fn ((n, mode, dbmode), mp) => IM.insert (mp, n, (mode, dbmode))) IM.empty sideInfo val ps = map (fn (ek, s, n, ts, t, _, b) => - (ek, s, n, ts, t, - getOpt (IM.find (sideInfo, n), L'.ServerOnly), - b)) ps + let + val (side, db) = getOpt (IM.find (sideInfo, n), (L'.ServerOnly, L'.AnyDb)) + in + (ek, s, n, ts, t, side, db, b) + end) ps in (List.revAppend (dsF, rev ds), ps) diff --git a/src/compiler.sig b/src/compiler.sig index fa131cf4..d74ec533 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -172,6 +172,7 @@ signature COMPILER = sig val toNamejs : (string, Mono.file) transform val toNamejs_untangle : (string, Mono.file) transform val toScriptcheck : (string, Mono.file) transform + val toDbmodecheck : (string, Mono.file) transform val toJscomp : (string, Mono.file) transform val toMono_opt3 : (string, Mono.file) transform val toFuse : (string, Mono.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 2190684a..716cc3d3 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1401,12 +1401,19 @@ val scriptcheck = { val toScriptcheck = transform scriptcheck "scriptcheck" o toNamejs_untangle +val dbmodecheck = { + func = DbModeCheck.classify, + print = MonoPrint.p_file MonoEnv.empty +} + +val toDbmodecheck = transform dbmodecheck "dbmodecheck" o toScriptcheck + val jscomp = { func = JsComp.process, print = MonoPrint.p_file MonoEnv.empty } -val toJscomp = transform jscomp "jscomp" o toScriptcheck +val toJscomp = transform jscomp "jscomp" o toDbmodecheck val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp diff --git a/src/dbmodecheck.sig b/src/dbmodecheck.sig new file mode 100644 index 00000000..4d4873c4 --- /dev/null +++ b/src/dbmodecheck.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2014, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +signature DB_MODE_CHECK = sig + + val classify : Mono.file -> Mono.file + +end diff --git a/src/dbmodecheck.sml b/src/dbmodecheck.sml new file mode 100644 index 00000000..eb416cea --- /dev/null +++ b/src/dbmodecheck.sml @@ -0,0 +1,86 @@ +(* Copyright (c) 2014, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure DbModeCheck :> DB_MODE_CHECK = struct + +open Mono + +structure IM = IntBinaryMap + +fun classify (ds, ps) = + let + fun mergeModes (m1, m2) = + case (m1, m2) of + (NoDb, _) => m2 + | (_, NoDb) => m1 + | _ => AnyDb + + fun modeOf modes = + MonoUtil.Exp.fold {typ = fn (_, dbm) => dbm, + exp = fn (EQuery _, dbm) => mergeModes (OneQuery, dbm) + | (EDml _, _) => AnyDb + | (ENextval _, _) => AnyDb + | (ESetval _, _) => AnyDb + | (ENamed n, dbm) => + (case IM.find (modes, n) of + NONE => dbm + | SOME dbm' => mergeModes (dbm, dbm')) + | (_, dbm) => dbm} NoDb + + fun decl ((d, _), modes) = + case d of + DVal (x, n, _, e, _) => IM.insert (modes, n, modeOf modes e) + | DValRec xes => + let + val mode = foldl (fn ((_, _, _, e, _), mode) => + let + val mode' = modeOf modes e + in + case mode' of + NoDb => mode + | _ => AnyDb + end) NoDb xes + in + foldl (fn ((_, n, _, _, _), modes) => IM.insert (modes, n, mode)) modes xes + end + | _ => modes + + val modes = foldl decl IM.empty ds + + val (ps, modes) = ListUtil.foldlMap (fn ((n, side, _), modes) => + case IM.find (modes, n) of + NONE => ((n, side, AnyDb), modes) + | SOME mode => ((n, side, mode), #1 (IM.remove (modes, n)))) + modes ps + + val ps = IM.foldli (fn (n, mode, ps) => (n, ServerOnly, mode) :: ps) ps modes + in + (ds, ps) + end + +end + diff --git a/src/mono.sml b/src/mono.sml index 78740d70..1e402e57 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2010, 2013, Adam Chlipala +(* Copyright (c) 2008-2010, 2013-2014, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -162,6 +162,11 @@ datatype sidedness = | ServerAndPull | ServerAndPullAndPush -type file = decl list * (int * sidedness) list +datatype dbmode = + NoDb + | OneQuery + | AnyDb + +type file = decl list * (int * sidedness * dbmode) list end diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml index e5db476a..4bc2a4cf 100644 --- a/src/scriptcheck.sml +++ b/src/scriptcheck.sml @@ -98,7 +98,7 @@ fun classify (ds, ps) = else if IS.member (pull_ids, n) then ServerAndPull else - ServerOnly)) (IS.listItems all_ids) + ServerOnly, AnyDb)) (IS.listItems all_ids) in (ds, ps) end diff --git a/src/sources b/src/sources index f75803a3..a5235357 100644 --- a/src/sources +++ b/src/sources @@ -223,6 +223,9 @@ $(SRC)/cjrize.sml $(SRC)/scriptcheck.sig $(SRC)/scriptcheck.sml +$(SRC)/dbmodecheck.sig +$(SRC)/dbmodecheck.sml + $(SRC)/prepare.sig $(SRC)/prepare.sml |