changeset 1112:7a31e0cf25e9

Proper C-side deserialization; Shake.sliceDb
author Adam Chlipala <adamc@hcoop.net>
date Sun, 03 Jan 2010 12:47:27 -0500
parents e1d738870086
children 40d48a2b78a7
files src/checknest.sml src/cjr.sml src/cjr_print.sml src/cjrize.sml src/jscomp.sml src/mono.sml src/mono_print.sml src/mono_reduce.sml src/mono_util.sml src/monoize.sml src/prepare.sml src/scriptcheck.sml src/shake.sig src/shake.sml
diffstat 14 files changed, 78 insertions(+), 29 deletions(-) [+]
line wrap: on
line diff
--- a/src/checknest.sml	Sat Jan 02 14:54:15 2010 -0500
+++ b/src/checknest.sml	Sun Jan 03 12:47:27 2010 -0500
@@ -89,7 +89,7 @@
                 end
               | ESetval {seq, count} => IS.union (eu seq, eu count)
 
-              | EUnurlify (e, _) => eu e
+              | EUnurlify (e, _, _) => eu e
     in
         eu
     end
@@ -149,7 +149,7 @@
                 (ESetval {seq = ae seq,
                           count = ae count}, loc)
 
-              | EUnurlify (e, t) => (EUnurlify (ae e, t), loc)
+              | EUnurlify (e, t, b) => (EUnurlify (ae e, t, b), loc)
     in
         ae
     end
--- a/src/cjr.sml	Sat Jan 02 14:54:15 2010 -0500
+++ b/src/cjr.sml	Sun Jan 03 12:47:27 2010 -0500
@@ -96,7 +96,7 @@
        | ENextval of { seq : exp,
                        prepared : {id : int, query : string} option }
        | ESetval of { seq : exp, count : exp }
-       | EUnurlify of exp * typ
+       | EUnurlify of exp * typ * bool
 
 withtype exp = exp' located
 
--- a/src/cjr_print.sml	Sat Jan 02 14:54:15 2010 -0500
+++ b/src/cjr_print.sml	Sun Jan 03 12:47:27 2010 -0500
@@ -1863,7 +1863,7 @@
              newline,
              string "})"]
 
-      | EUnurlify (e, t) =>
+      | EUnurlify (e, t, true) =>
         let
             fun getIt () =
                 if isUnboxable t then
@@ -1898,6 +1898,40 @@
                  string "})"]
         end
 
+      | EUnurlify (e, t, false) =>
+        let
+            fun getIt () =
+                if isUnboxable t then
+                    unurlify false env t
+                else
+                    box [string "({",
+                         newline,
+                         p_typ env t,
+                         string " *tmp = uw_malloc(ctx, sizeof(",
+                         p_typ env t,
+                         string "));",
+                         newline,
+                         string "*tmp = ",
+                         unurlify false env t,
+                         string ";",
+                         newline,
+                         string "tmp;",
+                         newline,
+                         string "})"]
+        in
+            box [string "({",
+                 newline,
+                 string "uw_Basis_string request = uw_maybe_strdup(ctx, ",
+                 p_exp env e,
+                 string ");",
+                 newline,
+                 newline,
+                 unurlify false env t,
+                 string ";",
+                 newline,
+                 string "})"]
+        end
+
 and p_exp env = p_exp' false env
 
 fun p_fun env (fx, n, args, ran, e) =
--- a/src/cjrize.sml	Sat Jan 02 14:54:15 2010 -0500
+++ b/src/cjrize.sml	Sun Jan 03 12:47:27 2010 -0500
@@ -476,12 +476,12 @@
             ((L'.ESetval {seq = e1, count = e2}, loc), sm)
         end
 
-      | L.EUnurlify (e, t) =>
+      | L.EUnurlify (e, t, b) =>
         let
             val (e, sm) = cifyExp (e, sm)
             val (t, sm) = cifyTyp (t, sm)
         in
-            ((L'.EUnurlify (e, t), loc), sm)
+            ((L'.EUnurlify (e, t, b), loc), sm)
         end
 
       | L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains"
--- a/src/jscomp.sml	Sat Jan 02 14:54:15 2010 -0500
+++ b/src/jscomp.sml	Sun Jan 03 12:47:27 2010 -0500
@@ -869,10 +869,11 @@
                           | EDml _ => unsupported "DML"
                           | ENextval _ => unsupported "Nextval"
                           | ESetval _ => unsupported "Nextval"
-                          | EReturnBlob _ => unsupported "EUnurlify"
+                          | EReturnBlob _ => unsupported "EReturnBlob"
                           | ERedirect _ => unsupported "ERedirect"
+                          | EUnurlify (_, _, true) => unsupported "EUnurlify"
 
-                          | EUnurlify (e, t) =>
+                          | EUnurlify (e, t, false) =>
                             let
                                 val (e, st) = jsE inner (e, st)
                                 val (e', st) = unurlifyExp loc (t, st)
@@ -1162,11 +1163,11 @@
                      ((ESetval (e1, e2), loc), st)
                  end
 
-               | EUnurlify (e, t) =>
+               | EUnurlify (e, t, b) =>
                  let
                      val (e, st) = exp outer (e, st)
                  in
-                     ((EUnurlify (e, t), loc), st)
+                     ((EUnurlify (e, t, b), loc), st)
                  end
 
                | EJavaScript (m, e') =>
--- a/src/mono.sml	Sat Jan 02 14:54:15 2010 -0500
+++ b/src/mono.sml	Sun Jan 03 12:47:27 2010 -0500
@@ -108,7 +108,7 @@
        | ENextval of exp
        | ESetval of exp * exp
 
-       | EUnurlify of exp * typ
+       | EUnurlify of exp * typ * bool
 
        | EJavaScript of javascript_mode * exp
 
--- a/src/mono_print.sml	Sat Jan 02 14:54:15 2010 -0500
+++ b/src/mono_print.sml	Sun Jan 03 12:47:27 2010 -0500
@@ -334,9 +334,9 @@
                                  space,
                                  p_exp env e2,
                                  string ")"]
-      | EUnurlify (e, _) => box [string "unurlify(",
-                                 p_exp env e,
-                                 string ")"]
+      | EUnurlify (e, _, _) => box [string "unurlify(",
+                                    p_exp env e,
+                                    string ")"]
       | EJavaScript (m, e) => box [string "JavaScript(",
                                    p_mode env m,
                                    string ",",
--- a/src/mono_reduce.sml	Sat Jan 02 14:54:15 2010 -0500
+++ b/src/mono_reduce.sml	Sun Jan 03 12:47:27 2010 -0500
@@ -451,7 +451,7 @@
                       | EDml e => summarize d e @ [WriteDb]
                       | ENextval e => summarize d e @ [WriteDb]
                       | ESetval (e1, e2) => summarize d e1 @ summarize d e2 @ [WriteDb]
-                      | EUnurlify (e, _) => summarize d e
+                      | EUnurlify (e, _, _) => summarize d e
                       | EJavaScript (_, e) => summarize d e
                       | ESignalReturn e => summarize d e
                       | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
--- a/src/mono_util.sml	Sat Jan 02 14:54:15 2010 -0500
+++ b/src/mono_util.sml	Sun Jan 03 12:47:27 2010 -0500
@@ -346,12 +346,12 @@
                         S.map2 (mfe ctx e2,
                              fn e2' =>
                                 (ESetval (e1', e2'), loc)))
-              | EUnurlify (e, t) =>
+              | EUnurlify (e, t, b) =>
                 S.bind2 (mfe ctx e,
                      fn e' =>
                         S.map2 (mft t,
                                 fn t' =>
-                                   (EUnurlify (e', t'), loc)))
+                                   (EUnurlify (e', t', b), loc)))
               | EJavaScript (m, e) =>
                 S.bind2 (mfmode ctx m,
                          fn m' =>
--- a/src/monoize.sml	Sat Jan 02 14:54:15 2010 -0500
+++ b/src/monoize.sml	Sun Jan 03 12:47:27 2010 -0500
@@ -1338,7 +1338,7 @@
                 ((L'.EAbs ("c", s, (L'.TFun (un, s), loc),
                            (L'.EAbs ("_", un, s,
                                      (L'.EUnurlify ((L'.EFfiApp ("Basis", "get_cookie", [(L'.ERel 1, loc)]), loc),
-                                                    t),
+                                                    t, true),
                                       loc)), loc)), loc),
                  fm)
             end
@@ -3255,7 +3255,8 @@
             let
                 val t = monoType env t
             in
-                ((L'.EAbs ("v", (L'.TFfi ("Basis", "string"), loc), t, (L'.EUnurlify ((L'.ERel 0, loc), t), loc)), loc),
+                ((L'.EAbs ("v", (L'.TFfi ("Basis", "string"), loc), t, (L'.EUnurlify ((L'.ERel 0, loc), t, false),
+                                                                        loc)), loc),
                  fm)
             end
 
--- a/src/prepare.sml	Sat Jan 02 14:54:15 2010 -0500
+++ b/src/prepare.sml	Sun Jan 03 12:47:27 2010 -0500
@@ -281,11 +281,11 @@
             ((ESetval {seq = e1, count = e2}, loc), st)
         end
 
-      | EUnurlify (e, t) =>
+      | EUnurlify (e, t, b) =>
         let
             val (e, st) = prepExp (e, st)
         in
-            ((EUnurlify (e, t), loc), st)
+            ((EUnurlify (e, t, b), loc), st)
         end
 
 fun prepDecl (d as (_, loc), st) =
--- a/src/scriptcheck.sml	Sat Jan 02 14:54:15 2010 -0500
+++ b/src/scriptcheck.sml	Sun Jan 03 12:47:27 2010 -0500
@@ -115,7 +115,7 @@
                       | EDml {dml, ...} => hasClient dml
                       | ENextval {seq, ...} => hasClient seq
                       | ESetval {seq, count, ...} => hasClient seq orelse hasClient count
-                      | EUnurlify (e, _) => hasClient e
+                      | EUnurlify (e, _, _) => hasClient e
             in
                 hasClient
             end
--- a/src/shake.sig	Sat Jan 02 14:54:15 2010 -0500
+++ b/src/shake.sig	Sun Jan 03 12:47:27 2010 -0500
@@ -31,4 +31,7 @@
 
     val shake : Core.file -> Core.file
 
+    val sliceDb : bool ref
+    (* Set this to try to delete anything not needed to determine the database schema. *)
+
 end
--- a/src/shake.sml	Sat Jan 02 14:54:15 2010 -0500
+++ b/src/shake.sml	Sun Jan 03 12:47:27 2010 -0500
@@ -29,6 +29,8 @@
 
 structure Shake :> SHAKE = struct
 
+val sliceDb = ref false
+
 open Core
 
 structure U = CoreUtil
@@ -67,7 +69,11 @@
 
         val (usedE, usedC) =
             List.foldl
-                (fn ((DExport (_, n, _), _), (usedE, usedC)) => (IS.add (usedE, n), usedC)
+                (fn ((DExport (_, n, _), _), st as (usedE, usedC)) =>
+                    if !sliceDb then
+                        st
+                    else
+                        (IS.add (usedE, n), usedC)
                   | ((DTable (_, _, c, _, pe, pc, ce, cc), _), (usedE, usedC)) =>
                     let
                         val usedC = usedVarsC usedC c
@@ -79,7 +85,11 @@
                     in
                         (usedE, usedC)
                     end
-                  | ((DTask (e1, e2), _), st) => usedVars (usedVars st e1) e2
+                  | ((DTask (e1, e2), _), st) =>
+                    if !sliceDb then
+                        st
+                    else
+                        usedVars (usedVars st e1) e2
                   | (_, acc) => acc) (IS.empty, IS.empty) file
 
         val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef)
@@ -186,14 +196,14 @@
                       | (DDatatype dts, _) => List.exists (fn (_, n, _, _) => IS.member (#con s, n)) dts
                       | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n)
                       | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis
-                      | (DExport _, _) => true
+                      | (DExport _, _) => not (!sliceDb)
                       | (DView _, _) => true
                       | (DSequence _, _) => true
                       | (DTable _, _) => true
-                      | (DDatabase _, _) => true
-                      | (DCookie _, _) => true
-                      | (DStyle _, _) => true
-                      | (DTask _, _) => true) file
+                      | (DDatabase _, _) => not (!sliceDb)
+                      | (DCookie _, _) => not (!sliceDb)
+                      | (DStyle _, _) => not (!sliceDb)
+                      | (DTask _, _) => not (!sliceDb)) file
     end
 
 end