Mercurial > urweb
changeset 1021:7a4a55e05081
Use call/cc for recv and sleep
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 25 Oct 2009 15:29:21 -0400 |
| parents | dfe34fad749d |
| children | 4de35df3d545 |
| files | CHANGELOG lib/js/urweb.js src/cjrize.sml src/jscomp.sml src/mono.sml src/mono_print.sml src/mono_reduce.sml src/mono_util.sml src/monoize.sml |
| diffstat | 9 files changed, 68 insertions(+), 72 deletions(-) [+] |
line wrap: on
line diff
--- a/CHANGELOG Sun Oct 25 14:07:10 2009 -0400 +++ b/CHANGELOG Sun Oct 25 15:29:21 2009 -0400 @@ -4,7 +4,8 @@ - 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 ========
--- a/lib/js/urweb.js Sun Oct 25 14:07:10 2009 -0400 +++ b/lib/js/urweb.js Sun Oct 25 15:29:21 2009 -0400 @@ -779,10 +779,10 @@ 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 sl(ms, k) { - window.setTimeout(function() { execF(k, null); }, ms); + window.setTimeout(function() { k(null); }, ms); +} + +function sp(e) { + execF(e, null); }
--- a/src/cjrize.sml Sun Oct 25 14:07:10 2009 -0400 +++ b/src/cjrize.sml Sun Oct 25 15:29:21 2009 -0400 @@ -479,6 +479,7 @@ | 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
--- a/src/jscomp.sml Sun Oct 25 14:07:10 2009 -0400 +++ b/src/jscomp.sml Sun Oct 25 15:29:21 2009 -0400 @@ -918,31 +918,35 @@ 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 @@ 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) - val (e2, st) = exp outer (e2, st) in - ((ESleep (e1, e2), loc), st) + ((ESleep e1, loc), st) + end + | ESpawn e1 => + let + val (e1, st) = exp outer (e1, st) + in + ((ESpawn e1, loc), st) end) fun decl (d as (_, loc), st) =
--- a/src/mono.sml Sun Oct 25 14:07:10 2009 -0400 +++ b/src/mono.sml Sun Oct 25 15:29:21 2009 -0400 @@ -115,8 +115,9 @@ | 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
--- a/src/mono_print.sml Sun Oct 25 14:07:10 2009 -0400 +++ b/src/mono_print.sml Sun Oct 25 15:29:21 2009 -0400 @@ -338,16 +338,15 @@ | 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
--- a/src/mono_reduce.sml Sun Oct 25 14:07:10 2009 -0400 +++ b/src/mono_reduce.sml Sun Oct 25 15:29:21 2009 -0400 @@ -112,6 +112,7 @@ | EServerCall _ => true | ERecv _ => true | ESleep _ => true + | ESpawn _ => true val liftExpInExp = Monoize.liftExpInExp @@ -451,8 +452,9 @@ | 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)),
--- a/src/mono_util.sml Sun Oct 25 14:07:10 2009 -0400 +++ b/src/mono_util.sml Sun Oct 25 15:29:21 2009 -0400 @@ -368,20 +368,21 @@ 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' => - S.map2 (mfe ctx ek, - fn ek' => - (ESleep (s', ek'), loc))) + (ESleep s', loc)) + + | ESpawn s => + S.map2 (mfe ctx s, + fn s' => + (ESpawn s', loc)) and mfmode ctx mode = case mode of
--- a/src/monoize.sml Sun Oct 25 14:07:10 2009 -0400 +++ b/src/monoize.sml Sun Oct 25 15:29:21 2009 -0400 @@ -1207,42 +1207,21 @@ 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 un = (L'.TRecord [], loc) val t1 = monoType env t1 - val t2 = monoType env t2 - val un = (L'.TRecord [], loc) - val mt2 = (L'.TFun (un, t2), loc) 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 @@ 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)