From cfcc0c0553a13a83cf674b00828c89b6f9459936 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 4 Apr 2009 14:03:39 -0400 Subject: _Really_ implement embedded closure GC; extend Scriptcheck to figure out when client IDs must be assigned --- src/c/urweb.c | 9 +++++- src/cjr.sml | 3 +- src/cjr_print.sml | 17 ++++++++---- src/cjrize.sml | 2 +- src/jscomp.sml | 10 +++---- src/scriptcheck.sml | 80 ++++++++++++++++++++++++++++++++--------------------- 6 files changed, 77 insertions(+), 44 deletions(-) (limited to 'src') diff --git a/src/c/urweb.c b/src/c/urweb.c index ed19305e..880cd143 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -300,6 +300,8 @@ struct uw_context { const char *script_header, *url_prefix; + int needs_push; + size_t n_deltas, used_deltas; delta *deltas; @@ -333,6 +335,7 @@ uw_context uw_init() { ctx->script_header = ""; ctx->url_prefix = "/"; + ctx->needs_push = 0; ctx->error_message[0] = 0; @@ -476,7 +479,7 @@ uw_Basis_string uw_Basis_requestHeader(uw_context ctx, uw_Basis_string h) { } void uw_login(uw_context ctx) { - if (ctx->script_header[0]) { + if (ctx->needs_push) { char *id_s, *pass_s; if ((id_s = uw_Basis_requestHeader(ctx, "UrWeb-Client")) @@ -578,6 +581,10 @@ void uw_set_url_prefix(uw_context ctx, const char *s) { ctx->url_prefix = s; } +void uw_set_needs_push(uw_context ctx, int n) { + ctx->needs_push = n; +} + static void buf_check_ctx(uw_context ctx, buf *b, size_t extra, const char *desc) { if (b->back - b->front < extra) { diff --git a/src/cjr.sml b/src/cjr.sml index 41bb6a4c..78c2e63b 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -115,7 +115,8 @@ withtype decl = decl' located datatype sidedness = ServerOnly - | ServerAndClient + | ServerAndPull + | ServerAndPullAndPush type file = decl list * (Core.export_kind * string * int * typ list * typ * sidedness) list diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 9c652d4a..54ec3cbf 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2391,12 +2391,19 @@ fun p_file env (ds, ps) = newline, string "uw_set_script_header(ctx, \"", string (case side of - ServerAndClient => "\\n" - | ServerOnly => ""), + ServerOnly => "" + | _ => "\\n"), string "\");", + newline, + string "uw_set_needs_push(ctx, ", + string (case side of + ServerAndPullAndPush => "1" + | _ => "0"), + string ");", + newline, string "uw_set_url_prefix(ctx, \"", string (!Monoize.urlPrefix), string "\");", diff --git a/src/cjrize.sml b/src/cjrize.sml index 27287d6e..998ae38e 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -520,7 +520,7 @@ fun cifyDecl ((d, loc), sm) = val (ts, sm) = ListUtil.foldlMap cifyTyp sm ts val (t, sm) = cifyTyp (t, sm) in - (NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndClient), sm) + (NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndPullAndPush), sm) end | L.DTable (s, xts) => diff --git a/src/jscomp.sml b/src/jscomp.sml index 1409a0cb..c28f58d0 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -850,7 +850,7 @@ fun process file = val (e1, st) = jsE inner (e1, st) val (e2, st) = jsE inner (e2, st) in - (strcat [str "(", e1, str "+", e2, str ")"], st) + (strcat [str "cat(", e1, str ",", e2, str ")"], st) end | EError (e, _) => @@ -891,9 +891,9 @@ fun process file = | EJavaScript (Source _, _, SOME _) => (e, st) | EJavaScript (_, _, SOME e) => - (strcat [str "function(){return ", + (strcat [str "cs(function(){return ", e, - str "}"], + str "})"], st) | EClosure _ => unsupported "EClosure" @@ -905,9 +905,9 @@ fun process file = let val (e, st) = jsE inner (e, st) in - (strcat [str "function(){return ", + (strcat [str "cs(function(){return ", e, - str "}"], + str "})"], st) end diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml index 0b51747f..34bf2337 100644 --- a/src/scriptcheck.sml +++ b/src/scriptcheck.sml @@ -35,19 +35,21 @@ structure SS = BinarySetFn(struct end) structure IS = IntBinarySet -val csBasis = SS.addList (SS.empty, - ["new_client_source", - "get_client_source", - "set_client_source", - "new_channel", - "subscribe", - "send", - "recv"]) +val pullBasis = SS.addList (SS.empty, + ["new_client_source", + "get_client_source", + "set_client_source"]) +val pushBasis = SS.addList (SS.empty, + ["new_channel", + "self"]) + val scriptWords = [" List.exists (fn n => inString {needle = n, haystack = s}) scriptWords + EPrim (Prim.String s) => List.exists (fn n => inString {needle = n, haystack = s}) words | EPrim _ => false | ERel _ => false | ENamed n => IS.member (csids, n) @@ -69,9 +71,9 @@ fun classify (ds, ps) = | ECon (_, _, SOME e) => hasClient e | ENone _ => false | ESome (_, e) => hasClient e - | EFfi ("Basis", x) => SS.member (csBasis, x) + | EFfi ("Basis", x) => SS.member (basis, x) | EFfi _ => false - | EFfiApp ("Basis", x, es) => SS.member (csBasis, x) + | EFfiApp ("Basis", x, es) => SS.member (basis, x) orelse List.exists hasClient es | EFfiApp (_, _, es) => List.exists hasClient es | EApp (e, es) => hasClient e orelse List.exists hasClient es @@ -93,33 +95,49 @@ fun classify (ds, ps) = hasClient end - fun decl ((d, _), csids) = + fun decl ((d, _), (pull_ids, push_ids)) = let - val hasClient = hasClient csids + val hasClientPull = hasClient {basis = pullBasis, words = scriptWords} pull_ids + val hasClientPush = hasClient {basis = pushBasis, words = pushWords} push_ids in case d of - DVal (_, n, _, e) => if hasClient e then - IS.add (csids, n) - else - csids - | DFun (_, n, _, _, e) => if hasClient e then - IS.add (csids, n) - else - csids - | DFunRec xes => if List.exists (fn (_, _, _, _, e) => hasClient e) xes then - foldl (fn ((_, n, _, _, _), csids) => IS.add (csids, n)) - csids xes - else - csids - | _ => csids + DVal (_, n, _, e) => (if hasClientPull e then + IS.add (pull_ids, n) + else + pull_ids, + if hasClientPush e then + IS.add (push_ids, n) + else + push_ids) + | DFun (_, n, _, _, e) => (if hasClientPull e then + IS.add (pull_ids, n) + else + pull_ids, + if hasClientPush e then + IS.add (push_ids, n) + else + push_ids) + | DFunRec xes => (if List.exists (fn (_, _, _, _, e) => hasClientPull e) xes then + foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n)) + pull_ids xes + else + pull_ids, + if List.exists (fn (_, _, _, _, e) => hasClientPush e) xes then + foldl (fn ((_, n, _, _, _), push_ids) => IS.add (push_ids, n)) + push_ids xes + else + push_ids) + | _ => (pull_ids, push_ids) end - val csids = foldl decl IS.empty ds + val (pull_ids, push_ids) = foldl decl (IS.empty, IS.empty) ds val ps = map (fn (ek, x, n, ts, t, _) => (ek, x, n, ts, t, - if IS.member (csids, n) then - ServerAndClient + if IS.member (push_ids, n) then + ServerAndPullAndPush + else if IS.member (pull_ids, n) then + ServerAndPull else ServerOnly)) ps in -- cgit v1.2.3