Proper C-side deserialization; Shake.sliceDb

14 files changed, 78 insertions, 29 deletions

diff --git a/src/checknest.sml b/src/checknest.sml
index c0f843d6..a53c7083 100644
--- a/src/checknest.sml
+++ b/src/checknest.sml
@@ -89,7 +89,7 @@ fun expUses globals =
                 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 @@ fun annotateExp globals =
                 (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
diff --git a/src/cjr.sml b/src/cjr.sml
index 53448a29..a19109d2 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -96,7 +96,7 @@ datatype exp' =
        | 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
 
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 8c5a24b4..faf5f7b2 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1863,7 +1863,7 @@ fun p_exp' par env (e, loc) =
              newline,
              string "})"]
 
-      | EUnurlify (e, t) =>
+      | EUnurlify (e, t, true) =>
         let
             fun getIt () =
                 if isUnboxable t then
@@ -1898,6 +1898,40 @@ fun p_exp' par env (e, loc) =
                  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) =
diff --git a/src/cjrize.sml b/src/cjrize.sml
index e2807372..6e41a69b 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -476,12 +476,12 @@ fun cifyExp (eAll as (e, loc), sm) =
             ((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"
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 11d75a3a..b99a6858 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -869,10 +869,11 @@ fun process file =
                           | 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 @@ fun process file =
                      ((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') =>
diff --git a/src/mono.sml b/src/mono.sml
index af5e9031..898feb9b 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -108,7 +108,7 @@ datatype exp' =
        | ENextval of exp
        | ESetval of exp * exp
 
-       | EUnurlify of exp * typ
+       | EUnurlify of exp * typ * bool
 
        | EJavaScript of javascript_mode * exp
 
diff --git a/src/mono_print.sml b/src/mono_print.sml
index a5e795b2..d1f5fc27 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -334,9 +334,9 @@ fun p_exp' par env (e, _) =
                                  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 ",",
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 16cfd9f9..10de1c56 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -451,7 +451,7 @@ fun reduce file =
                       | 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
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 02619437..a75843c4 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -346,12 +346,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
                         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' =>
diff --git a/src/monoize.sml b/src/monoize.sml
index ff5a0f3a..bda6cfe4 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1338,7 +1338,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                 ((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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             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
 
diff --git a/src/prepare.sml b/src/prepare.sml
index 2d144c67..2f49405b 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -281,11 +281,11 @@ fun prepExp (e as (_, loc), st) =
             ((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) =
diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml
index 7dec8d80..129f4281 100644
--- a/src/scriptcheck.sml
+++ b/src/scriptcheck.sml
@@ -115,7 +115,7 @@ fun classify (ds, ps) =
                       | 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
diff --git a/src/shake.sig b/src/shake.sig
index 6c617435..2b805dea 100644
--- a/src/shake.sig
+++ b/src/shake.sig
@@ -31,4 +31,7 @@ signature SHAKE = sig
 
     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
diff --git a/src/shake.sml b/src/shake.sml
index 39ebdde0..686a043c 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -29,6 +29,8 @@
 
 structure Shake :> SHAKE = struct
 
+val sliceDb = ref false
+
 open Core
 
 structure U = CoreUtil
@@ -67,7 +69,11 @@ fun shake file =
 
         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 @@ fun shake file =
                     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 @@ fun shake file =
                       | (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