summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/cjr_print.sml2
-rw-r--r--src/cjrize.sml2
-rw-r--r--src/core.sml1
-rw-r--r--src/core_print.sml1
-rw-r--r--src/jscomp.sml4
-rw-r--r--src/mono.sml2
-rw-r--r--src/mono_print.sml9
-rw-r--r--src/mono_reduce.sml3
-rw-r--r--src/mono_util.sml7
-rw-r--r--src/monoize.sml8
-rw-r--r--src/rpcify.sml47
11 files changed, 73 insertions, 13 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index f8b1f23b..8f5c8551 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1849,6 +1849,7 @@ fun p_file env (ds, ps) =
val fields = foldl (fn ((ek, _, _, ts), fields) =>
case ek of
Core.Link => fields
+ | Core.Rpc => fields
| Core.Action =>
case List.nth (ts, length ts - 2) of
(TRecord i, _) =>
@@ -1971,6 +1972,7 @@ fun p_file env (ds, ps) =
val (ts, defInputs, inputsVar) =
case ek of
Core.Link => (List.take (ts, length ts - 1), string "", string "")
+ | Core.Rpc => (List.take (ts, length ts - 1), string "", string "")
| Core.Action =>
case List.nth (ts, length ts - 2) of
(TRecord i, _) =>
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 1a5d10c0..77674158 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -429,6 +429,8 @@ fun cifyExp (eAll as (e, loc), sm) =
| L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains"
| L.ESignalSource _ => raise Fail "Cjrize: ESignalSource remains"
+ | L.EServerCall _ => raise Fail "Cjrize EServerCall"
+
fun cifyDecl ((d, loc), sm) =
case d of
L.DDatatype (x, n, xncs) =>
diff --git a/src/core.sml b/src/core.sml
index fbe150c1..62f046fe 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -113,6 +113,7 @@ withtype exp = exp' located
datatype export_kind =
Link
| Action
+ | Rpc
datatype decl' =
DCon of string * int * kind * con
diff --git a/src/core_print.sml b/src/core_print.sml
index 64cead70..e9a36fbb 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -436,6 +436,7 @@ fun p_export_kind ck =
case ck of
Link => string "link"
| Action => string "action"
+ | Rpc => string "rpc"
fun p_datatype env (x, n, xs, cons) =
let
diff --git a/src/jscomp.sml b/src/jscomp.sml
index f61ec3f0..627ba8f6 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -98,6 +98,7 @@ fun varDepth (e, _) =
| ESignalReturn e => varDepth e
| ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2)
| ESignalSource e => varDepth e
+ | EServerCall (_, es, ek) => foldl Int.max (varDepth ek) (map varDepth es)
fun closedUpto d =
let
@@ -138,6 +139,7 @@ fun closedUpto d =
| ESignalReturn e => cu inner e
| ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2
| ESignalSource e => cu inner e
+ | EServerCall (_, es, ek) => List.all (cu inner) es andalso cu inner ek
in
cu 0
end
@@ -809,6 +811,8 @@ fun process file =
str ")"],
st)
end
+
+ | EServerCall _ => raise Fail "Jscomp EServerCall"
end
in
jsE
diff --git a/src/mono.sml b/src/mono.sml
index 8999704c..547f8a55 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -109,6 +109,8 @@ datatype exp' =
| ESignalBind of exp * exp
| ESignalSource of exp
+ | EServerCall of int * exp list * exp
+
withtype exp = exp' located
datatype decl' =
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 1e9de3d8..a859a1bd 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -308,6 +308,15 @@ fun p_exp' par env (e, _) =
p_exp env e,
string ")"]
+ | EServerCall (n, es, e) => box [string "Server(",
+ p_enamed env n,
+ string ",",
+ space,
+ p_list (p_exp env) es,
+ string ")[",
+ p_exp env e,
+ string "]"]
+
and p_exp env = p_exp' false env
fun p_vali env (x, n, t, e, s) =
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 878fec92..7d39648a 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -81,6 +81,7 @@ fun impure (e, _) =
| ESignalReturn e => impure e
| ESignalBind (e1, e2) => impure e1 orelse impure e2
| ESignalSource e => impure e
+ | EServerCall _ => true
val liftExpInExp = Monoize.liftExpInExp
@@ -344,6 +345,8 @@ fun reduce file =
| ESignalReturn e => summarize d e
| ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
| ESignalSource e => summarize d e
+
+ | EServerCall (_, es, ek) => List.concat (map (summarize d) es) @ summarize d ek @ [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 9ce3293b..13e0d32c 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -349,6 +349,13 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
S.map2 (mfe ctx e,
fn e' =>
(ESignalSource e', loc))
+
+ | EServerCall (n, es, ek) =>
+ S.bind2 (ListUtil.mapfold (fn e => mfe ctx e) es,
+ fn es' =>
+ S.map2 (mfe ctx ek,
+ fn ek' =>
+ (EServerCall (n, es', ek'), loc)))
in
mfe
end
diff --git a/src/monoize.sml b/src/monoize.sml
index a1f61143..fb1ac2f1 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2225,7 +2225,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.ELet (x, t', e1, e2), loc), fm)
end
- | L.EServerCall _ => raise Fail "Monoize EServerCall"
+ | L.EServerCall (n, es, ek) =>
+ let
+ val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
+ val (ek, fm) = monoExp (env, st, fm) ek
+ in
+ ((L'.EServerCall (n, es, ek), loc), fm)
+ end
end
fun monoDecl (env, fm) (all as (d, loc)) =
diff --git a/src/rpcify.sml b/src/rpcify.sml
index dec8dc18..09c44a7a 100644
--- a/src/rpcify.sml
+++ b/src/rpcify.sml
@@ -53,8 +53,11 @@ val csBasis = SS.addList (SS.empty,
"alert"])
type state = {
- exps : int IM.map,
- decls : (string * int * con * exp * string) list
+ cpsed : int IM.map,
+ cps_decls : (string * int * con * exp * string) list,
+
+ exported : IS.set,
+ export_decls : decl list
}
fun frob file =
@@ -114,6 +117,19 @@ fun frob file =
(0, []))
val (n, args) = getApp (trans1, [])
+
+ val (exported, export_decls) =
+ if IS.member (#exported st, n) then
+ (#exported st, #export_decls st)
+ else
+ (IS.add (#exported st, n),
+ (DExport (Rpc, n), loc) :: #export_decls st)
+
+ val st = {cpsed = #cpsed st,
+ cps_decls = #cps_decls st,
+
+ exported = exported,
+ export_decls = export_decls}
in
(EServerCall (n, args, trans2), st)
end
@@ -128,19 +144,26 @@ fun frob file =
decl = fn x => x}
st d
in
- (case #decls st of
- [] => [d]
- | ds =>
- case d of
- (DValRec vis, loc) => [(DValRec (ds @ vis), loc)]
- | (_, loc) => [(DValRec ds, loc), d],
- {decls = [],
- exps = #exps st})
+ (List.revAppend (case #cps_decls st of
+ [] => [d]
+ | ds =>
+ case d of
+ (DValRec vis, loc) => [(DValRec (ds @ vis), loc)]
+ | (_, loc) => [d, (DValRec ds, loc)],
+ #export_decls st),
+ {cpsed = #cpsed st,
+ cps_decls = [],
+
+ exported = #exported st,
+ export_decls = []})
end
val (file, _) = ListUtil.foldlMapConcat decl
- {decls = [],
- exps = IM.empty}
+ {cpsed = IM.empty,
+ cps_decls = [],
+
+ exported = IS.empty,
+ export_decls = []}
file
in
file
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-09 08:22:59 +0000