summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--CHANGELOG3
-rw-r--r--lib/js/urweb.js10
-rw-r--r--src/cjrize.sml1
-rw-r--r--src/jscomp.sml40
-rw-r--r--src/mono.sml5
-rw-r--r--src/mono_print.sml19
-rw-r--r--src/mono_reduce.sml6
-rw-r--r--src/mono_util.sml23
-rw-r--r--src/monoize.sml33
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)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-03 23:51:07 +0000