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 (2009-10-25)
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)