changeset 2056:a9159911c3ba

New phase: Dbmodecheck
author Adam Chlipala <adam@chlipala.net>
date Sun, 17 Aug 2014 13:07:56 -0400 (2014-08-17)
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
--- a/src/scriptcheck.sml	Sun Aug 10 13:40:53 2014 -0400
+++ b/src/scriptcheck.sml	Sun Aug 17 13:07:56 2014 -0400
@@ -98,7 +98,7 @@
                              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
--- a/src/sources	Sun Aug 10 13:40:53 2014 -0400
+++ b/src/sources	Sun Aug 17 13:07:56 2014 -0400
@@ -223,6 +223,9 @@
 $(SRC)/scriptcheck.sig
 $(SRC)/scriptcheck.sml
 
+$(SRC)/dbmodecheck.sig
+$(SRC)/dbmodecheck.sml
+
 $(SRC)/prepare.sig
 $(SRC)/prepare.sml