Mercurial > urweb
changeset 2056:a9159911c3ba
New phase: Dbmodecheck
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Sun, 17 Aug 2014 13:07:56 -0400 |
| parents | 7c2229aa22fc |
| children | f4a6ccb7937f |
| files | include/urweb/urweb_cpp.h src/c/urweb.c src/cjr.sml src/cjr_print.sml src/cjrize.sml src/compiler.sig src/compiler.sml src/dbmodecheck.sig src/dbmodecheck.sml src/mono.sml src/scriptcheck.sml src/sources |
| diffstat | 12 files changed, 160 insertions(+), 13 deletions(-) [+] |
line wrap: on
line diff
--- a/include/urweb/urweb_cpp.h Sun Aug 10 13:40:53 2014 -0400 +++ b/include/urweb/urweb_cpp.h Sun Aug 17 13:07:56 2014 -0400 @@ -90,6 +90,7 @@ 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);
--- a/src/c/urweb.c Sun Aug 10 13:40:53 2014 -0400 +++ b/src/c/urweb.c Sun Aug 17 13:07:56 2014 -0400 @@ -441,7 +441,7 @@ 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 @@ 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 @@ } 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 @@ 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) {
--- a/src/cjr.sml Sun Aug 10 13:40:53 2014 -0400 +++ b/src/cjr.sml Sun Aug 17 13:07:56 2014 -0400 @@ -129,10 +129,11 @@ 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
--- a/src/cjr_print.sml Sun Aug 10 13:40:53 2014 -0400 +++ b/src/cjr_print.sml Sun Aug 17 13:07:56 2014 -0400 @@ -2634,7 +2634,7 @@ 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 @@ 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 @@ 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"
--- a/src/cjrize.sml Sun Aug 10 13:40:53 2014 -0400 +++ b/src/cjrize.sml Sun Aug 17 13:07:56 2014 -0400 @@ -730,12 +730,14 @@ 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)
--- a/src/compiler.sig Sun Aug 10 13:40:53 2014 -0400 +++ b/src/compiler.sig Sun Aug 17 13:07:56 2014 -0400 @@ -172,6 +172,7 @@ 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
--- a/src/compiler.sml Sun Aug 10 13:40:53 2014 -0400 +++ b/src/compiler.sml Sun Aug 17 13:07:56 2014 -0400 @@ -1401,12 +1401,19 @@ 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/dbmodecheck.sig Sun Aug 17 13:07:56 2014 -0400 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/dbmodecheck.sml Sun Aug 17 13:07:56 2014 -0400 @@ -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 +
--- a/src/mono.sml Sun Aug 10 13:40:53 2014 -0400 +++ b/src/mono.sml Sun Aug 17 13:07:56 2014 -0400 @@ -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 @@ | ServerAndPull | ServerAndPullAndPush -type file = decl list * (int * sidedness) list +datatype dbmode = + NoDb + | OneQuery + | AnyDb + +type file = decl list * (int * sidedness * dbmode) list end