Use call/cc for recv and sleep

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)