# HG changeset patch # User Adam Chlipala # Date 1262540847 18000 # Node ID 7a31e0cf25e959ce64b7edc41cc41ed661fb9527 # Parent e1d738870086099be1841492e91fe03e5124d560 Proper C-side deserialization; Shake.sliceDb diff -r e1d738870086 -r 7a31e0cf25e9 src/checknest.sml --- 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 diff -r e1d738870086 -r 7a31e0cf25e9 src/cjr.sml --- 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 diff -r e1d738870086 -r 7a31e0cf25e9 src/cjr_print.sml --- 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) = diff -r e1d738870086 -r 7a31e0cf25e9 src/cjrize.sml --- 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" diff -r e1d738870086 -r 7a31e0cf25e9 src/jscomp.sml --- 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') => diff -r e1d738870086 -r 7a31e0cf25e9 src/mono.sml --- 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 diff -r e1d738870086 -r 7a31e0cf25e9 src/mono_print.sml --- 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 ",", diff -r e1d738870086 -r 7a31e0cf25e9 src/mono_reduce.sml --- 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 diff -r e1d738870086 -r 7a31e0cf25e9 src/mono_util.sml --- 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' => diff -r e1d738870086 -r 7a31e0cf25e9 src/monoize.sml --- 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 diff -r e1d738870086 -r 7a31e0cf25e9 src/prepare.sml --- 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) = diff -r e1d738870086 -r 7a31e0cf25e9 src/scriptcheck.sml --- 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 diff -r e1d738870086 -r 7a31e0cf25e9 src/shake.sig --- 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 diff -r e1d738870086 -r 7a31e0cf25e9 src/shake.sml --- 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