From 2385b6b946eb1215d75a3dddccb05aaf8f605ba3 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 25 Oct 2009 15:29:21 -0400 Subject: Use call/cc for recv and sleep --- CHANGELOG | 3 ++- lib/js/urweb.js | 10 +++++++--- src/cjrize.sml | 1 + src/jscomp.sml | 40 ++++++++++++++++++++++++---------------- src/mono.sml | 5 +++-- src/mono_print.sml | 19 +++++++++---------- src/mono_reduce.sml | 6 ++++-- src/mono_util.sml | 23 ++++++++++++----------- src/monoize.sml | 33 ++++++--------------------------- 9 files changed, 68 insertions(+), 72 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index f1a1b7db..5ac1a04a 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -4,7 +4,8 @@ Next - Bug fixes - Optimization improvements -- Removed a restriction that prevented some RPCs from compiling +- Removed a restriction that prevented some RPCs and calls to sleep or recv + from compiling - New extra demo: conference1 ======== diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 6ca4becd..62f94f52 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -779,10 +779,10 @@ function rv(chn, parse, k) { var msg = dequeue(ch.msgs); if (msg == null) { - enqueue(ch.listeners, function(msg) { execF(execF(k, parse(msg)), null); }); + enqueue(ch.listeners, function(msg) { k(parse(msg)); }); } else { try { - execF(execF(k, parse(msg)), null); + k(parse(msg)); } catch (v) { doExn(v); } @@ -790,7 +790,11 @@ function rv(chn, parse, k) { } function sl(ms, k) { - window.setTimeout(function() { execF(k, null); }, ms); + window.setTimeout(function() { k(null); }, ms); +} + +function sp(e) { + execF(e, null); } diff --git a/src/cjrize.sml b/src/cjrize.sml index bf814266..c7bf7c9d 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -479,6 +479,7 @@ fun cifyExp (eAll as (e, loc), sm) = | L.EServerCall _ => raise Fail "Cjrize EServerCall" | L.ERecv _ => raise Fail "Cjrize ERecv" | L.ESleep _ => raise Fail "Cjrize ESleep" + | L.ESpawn _ => raise Fail "Cjrize ESpawn" fun cifyDecl ((d, loc), sm) = case d of diff --git a/src/jscomp.sml b/src/jscomp.sml index 9d456c5c..c6b8e7b9 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -918,31 +918,35 @@ fun process file = st) end - | ERecv (e, ek, t) => + | ERecv (e, t) => let val (e, st) = jsE inner (e, st) - val (ek, st) = jsE inner (ek, st) val (unurl, st) = unurlifyExp loc (t, st) in (strcat [str ("{c:\"f\",f:rv,a:cons("), e, str (",cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return " - ^ unurl ^ "}},cons("), - ek, - str (",null)))}")], + ^ unurl ^ "}},cons({c:\"K\"},null)))}")], st) end - | ESleep (e, ek) => + | ESleep e => let val (e, st) = jsE inner (e, st) - val (ek, st) = jsE inner (ek, st) in (strcat [str "{c:\"f\",f:sl,a:cons(", e, - str ",cons(", - ek, - str ",null))}"], + str ",cons({c:\"K\"},null))}"], + st) + end + + | ESpawn e => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "{c:\"f\",f:sp,a:cons(", + e, + str ",null)}"], st) end end @@ -1168,19 +1172,23 @@ fun process file = in ((EServerCall (e1, t, ef), loc), st) end - | ERecv (e1, e2, t) => + | ERecv (e1, t) => let val (e1, st) = exp outer (e1, st) - val (e2, st) = exp outer (e2, st) in - ((ERecv (e1, e2, t), loc), st) + ((ERecv (e1, t), loc), st) end - | ESleep (e1, e2) => + | ESleep e1 => + let + val (e1, st) = exp outer (e1, st) + in + ((ESleep e1, loc), st) + end + | ESpawn e1 => let val (e1, st) = exp outer (e1, st) - val (e2, st) = exp outer (e2, st) in - ((ESleep (e1, e2), loc), st) + ((ESpawn e1, loc), st) end) fun decl (d as (_, loc), st) = diff --git a/src/mono.sml b/src/mono.sml index 7ce6cee1..35aada16 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -115,8 +115,9 @@ datatype exp' = | ESignalSource of exp | EServerCall of exp * typ * effect - | ERecv of exp * exp * typ - | ESleep of exp * exp + | ERecv of exp * typ + | ESleep of exp + | ESpawn of exp withtype exp = exp' located diff --git a/src/mono_print.sml b/src/mono_print.sml index 49b636c3..6ac3393d 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -338,16 +338,15 @@ fun p_exp' par env (e, _) = | EServerCall (n, _, _) => box [string "Server(", p_exp env n, string ")"] - | ERecv (n, e, _) => box [string "Recv(", - p_exp env n, - string ")[", - p_exp env e, - string "]"] - | ESleep (n, e) => box [string "Sleep(", - p_exp env n, - string ")[", - p_exp env e, - string "]"] + | ERecv (n, _) => box [string "Recv(", + p_exp env n, + string ")"] + | ESleep n => box [string "Sleep(", + p_exp env n, + string ")"] + | ESpawn n => box [string "Spawn(", + p_exp env n, + string ")"] and p_exp env = p_exp' false env diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index d09c957c..04cd199e 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -112,6 +112,7 @@ fun impure (e, _) = | EServerCall _ => true | ERecv _ => true | ESleep _ => true + | ESpawn _ => true val liftExpInExp = Monoize.liftExpInExp @@ -451,8 +452,9 @@ fun reduce file = | ESignalSource e => summarize d e | EServerCall (e, _, _) => summarize d e @ [Unsure] - | ERecv (e, _, _) => summarize d e @ [Unsure] - | ESleep (e, _) => summarize d e @ [Unsure] + | ERecv (e, _) => summarize d e @ [Unsure] + | ESleep e => summarize d e @ [Unsure] + | ESpawn e => summarize d e @ [Unsure] in (*Print.prefaces "Summarize" [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)), diff --git a/src/mono_util.sml b/src/mono_util.sml index 24024470..f8e45dc3 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -368,20 +368,21 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mft t, fn t' => (EServerCall (s', t', eff), loc))) - | ERecv (s, ek, t) => + | ERecv (s, t) => S.bind2 (mfe ctx s, fn s' => - S.bind2 (mfe ctx ek, - fn ek' => - S.map2 (mft t, - fn t' => - (ERecv (s', ek', t'), loc)))) - | ESleep (s, ek) => - S.bind2 (mfe ctx s, + S.map2 (mft t, + fn t' => + (ERecv (s', t'), loc))) + | ESleep s => + S.map2 (mfe ctx s, + fn s' => + (ESleep s', loc)) + + | ESpawn s => + S.map2 (mfe ctx s, fn s' => - S.map2 (mfe ctx ek, - fn ek' => - (ESleep (s', ek'), loc))) + (ESpawn s', loc)) and mfmode ctx mode = case mode of diff --git a/src/monoize.sml b/src/monoize.sml index ff01b7f7..4e337388 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1207,42 +1207,21 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end - | L.EApp ((L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), _), _), t2), _), - (L.EFfi ("Basis", "transaction_monad"), _)), _), - (L.EApp ((L.ECApp ((L.EFfi ("Basis", "recv"), _), t1), _), - ch), loc)) => + | L.EApp ((L.ECApp ((L.EFfi ("Basis", "recv"), _), t1), _), ch) => let - val t1 = monoType env t1 - val t2 = monoType env t2 val un = (L'.TRecord [], loc) - val mt2 = (L'.TFun (un, t2), loc) + val t1 = monoType env t1 val (ch, fm) = monoExp (env, st, fm) ch in - ((L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc), - (L'.EAbs ("_", un, un, - (L'.ERecv (liftExpInExp 0 (liftExpInExp 0 ch), - (L'.ERel 1, loc), - t1), loc)), loc)), loc), - fm) + ((L'.EAbs ("_", un, un, (L'.ERecv (liftExpInExp 0 ch, t1), loc)), loc), fm) end | L.EFfiApp ("Basis", "recv", _) => poly () - | L.EApp ((L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), _), _), t2), _), - (L.EFfi ("Basis", "transaction_monad"), _)), _), - (L.EAbs (_, _, _, - (L.EFfiApp ("Basis", "sleep", [n]), _)), loc)) => + | L.EFfiApp ("Basis", "sleep", [n]) => let - val t2 = monoType env t2 - val un = (L'.TRecord [], loc) - val mt2 = (L'.TFun (un, t2), loc) val (n, fm) = monoExp (env, st, fm) n in - ((L'.EAbs ("m2", (L'.TFun (un, mt2), loc), (L'.TFun (un, un), loc), - (L'.EAbs ("_", un, un, - (L'.ESleep (liftExpInExp 0 n, (L'.EApp ((L'.ERel 1, loc), - (L'.ERecord [], loc)), loc)), - loc)), loc)), loc), - fm) + ((L'.ESleep n, loc), fm) end | L.EFfiApp ("Basis", "sleep", _) => poly () @@ -1302,7 +1281,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val (e, fm) = monoExp (env, st, fm) e in - ((L'.EApp (e, (L'.ERecord [], loc)), loc), fm) + ((L'.ESpawn e, loc), fm) end | L.EFfi ("Basis", "signal_monad") => ((L'.ERecord [], loc), fm) -- cgit v1.2.3