summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/core.sml2
-rw-r--r--src/core_print.sml16
-rw-r--r--src/core_util.sml12
-rw-r--r--src/effectize.sml4
-rw-r--r--src/monoize.sml5
-rw-r--r--src/reduce.sml103
-rw-r--r--src/reduce_local.sml2
-rw-r--r--src/rpcify.sml433
-rw-r--r--src/shake.sml2
9 files changed, 180 insertions, 399 deletions
diff --git a/src/core.sml b/src/core.sml
index e7466746..2b2d5ca5 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -115,7 +115,7 @@ datatype exp' =
| ELet of string * con * exp * exp
- | EServerCall of int * exp list * exp * con
+ | EServerCall of int * exp list * exp * con * con
withtype exp = exp' located
diff --git a/src/core_print.sml b/src/core_print.sml
index 08739aea..5daf7137 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -437,14 +437,14 @@ fun p_exp' par env (e, _) =
newline,
p_exp (E.pushERel env x t) e2]
- | 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 "]"]
+ | 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 "]"]
| EKAbs (x, e) => box [string x,
space,
diff --git a/src/core_util.sml b/src/core_util.sml
index db1eab1a..197f688a 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -532,7 +532,7 @@ fun compare ((e1, _), (e2, _)) =
| (ELet _, _) => LESS
| (_, ELet _) => GREATER
- | (EServerCall (n1, es1, e1, _), EServerCall (n2, es2, e2, _)) =>
+ | (EServerCall (n1, es1, e1, _, _), EServerCall (n2, es2, e2, _, _)) =>
join (Int.compare (n1, n2),
fn () => join (joinL compare (es1, es2),
fn () => compare (e1, e2)))
@@ -718,14 +718,16 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
fn e2' =>
(ELet (x, t', e1', e2'), loc))))
- | EServerCall (n, es, e, t) =>
+ | EServerCall (n, es, e, t1, t2) =>
S.bind2 (ListUtil.mapfold (mfe ctx) es,
fn es' =>
S.bind2 (mfe ctx e,
fn e' =>
- S.map2 (mfc ctx t,
- fn t' =>
- (EServerCall (n, es', e', t'), loc))))
+ S.bind2 (mfc ctx t1,
+ fn t1' =>
+ S.map2 (mfc ctx t2,
+ fn t2' =>
+ (EServerCall (n, es', e', t1', t2'), loc)))))
| EKAbs (x, e) =>
S.map2 (mfe (bind (ctx, RelK x)) e,
diff --git a/src/effectize.sml b/src/effectize.sml
index c07f74bc..d458561d 100644
--- a/src/effectize.sml
+++ b/src/effectize.sml
@@ -46,7 +46,7 @@ fun effectize file =
EFfi f => effectful f
| EFfiApp (m, x, _) => effectful (m, x)
| ENamed n => IM.inDomain (evs, n)
- | EServerCall (n, _, _, _) => IM.inDomain (evs, n)
+ | EServerCall (n, _, _, _, _) => IM.inDomain (evs, n)
| _ => false
fun couldWriteOnload evs = U.Exp.exists {kind = fn _ => false,
@@ -70,7 +70,7 @@ fun effectize file =
case e of
EFfi ("Basis", "getCookie") => true
| ENamed n => IM.inDomain (evs, n)
- | EServerCall (n, _, _, _) => IM.inDomain (evs, n)
+ | EServerCall (n, _, _, _, _) => IM.inDomain (evs, n)
| _ => false
fun couldReadCookie evs = U.Exp.exists {kind = fn _ => false,
diff --git a/src/monoize.sml b/src/monoize.sml
index 4d48a7ff..a5772976 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3137,7 +3137,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.ELet (x, t', e1, e2), loc), fm)
end
- | L.EServerCall (n, es, ek, t) =>
+ | L.EServerCall (n, es, ek, t, (L.TRecord (L.CRecord (_, []), _), _)) =>
let
val t = monoType env t
val (_, ft, _, name) = Env.lookupENamed env n
@@ -3192,6 +3192,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
in
(e, fm)
end
+ | L.EServerCall _ => (E.errorAt loc "Full scope of server call continuation isn't known";
+ Print.eprefaces' [("Expression", CorePrint.p_exp env all)];
+ (dummyExp, fm))
| L.EKAbs _ => poly ()
| L.EKApp _ => poly ()
diff --git a/src/reduce.sml b/src/reduce.sml
index a6c0b38a..88d3f2d9 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -33,6 +33,14 @@ open Core
structure IM = IntBinaryMap
+structure E = CoreEnv
+
+fun multiLiftExpInExp n e =
+ if n = 0 then
+ e
+ else
+ multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e)
+
datatype env_item =
UnknownK
| KnownK of kind
@@ -254,6 +262,98 @@ fun kindConAndExp (namedC, namedE) =
| EFfi _ => all
| EFfiApp (m, f, es) => (EFfiApp (m, f, map (exp env) es), loc)
+ | EApp (
+ (EApp
+ ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
+ _), _),
+ (EApp (
+ (EApp (
+ (ECApp (
+ (ECApp ((EFfi ("Basis", "return"), _), _), _),
+ _), _),
+ _), _), v), _)), _), trans2) => exp env (EApp (trans2, v), loc)
+
+ (*| EApp (
+ (EApp
+ ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
+ (EFfi ("Basis", "transaction_monad"), _)), _),
+ (ECase (ed, pes, {disc, ...}), _)), _),
+ trans2) =>
+ let
+ val e' = (EFfi ("Basis", "bind"), loc)
+ val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
+ val e' = (ECApp (e', t1), loc)
+ val e' = (ECApp (e', t2), loc)
+ val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
+
+ val pes = map (fn (p, e) =>
+ let
+ val e' = (EApp (e', e), loc)
+ val e' = (EApp (e',
+ multiLiftExpInExp (E.patBindsN p)
+ trans2), loc)
+ val e' = exp env e'
+ in
+ (p, e')
+ end) pes
+ in
+ (ECase (exp env ed,
+ pes,
+ {disc = con env disc,
+ result = (CApp ((CFfi ("Basis", "transaction"), loc), con env t2), loc)}),
+ loc)
+ end*)
+
+ | EApp (
+ (EApp
+ ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
+ (EFfi ("Basis", "transaction_monad"), _)), _),
+ (EServerCall (n, es, ke, dom, ran), _)), _),
+ trans2) =>
+ let
+ val e' = (EFfi ("Basis", "bind"), loc)
+ val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
+ val e' = (ECApp (e', dom), loc)
+ val e' = (ECApp (e', t2), loc)
+ val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
+ val e' = (EApp (e', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc)
+ val e' = (EApp (e', E.liftExpInExp 0 trans2), loc)
+ val e' = (EAbs ("x", dom, t2, e'), loc)
+ val e' = (EServerCall (n, es, e', dom, t2), loc)
+ in
+ exp env e'
+ end
+
+ | EApp (
+ (EApp
+ ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), _), _), t3), _),
+ (EFfi ("Basis", "transaction_monad"), _)), _),
+ (EApp ((EApp
+ ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
+ (EFfi ("Basis", "transaction_monad"), _)), _),
+ trans1), _), trans2), _)), _),
+ trans3) =>
+ let
+ val e'' = (EFfi ("Basis", "bind"), loc)
+ val e'' = (ECApp (e'', (CFfi ("Basis", "transaction"), loc)), loc)
+ val e'' = (ECApp (e'', t2), loc)
+ val e'' = (ECApp (e'', t3), loc)
+ val e'' = (EApp (e'', (EFfi ("Basis", "transaction_monad"), loc)), loc)
+ val e'' = (EApp (e'', (EApp (E.liftExpInExp 0 trans2, (ERel 0, loc)), loc)), loc)
+ val e'' = (EApp (e'', E.liftExpInExp 0 trans3), loc)
+ val e'' = (EAbs ("x", t1, (CApp ((CFfi ("Basis", "transaction"), loc), t3), loc), e''), loc)
+
+ val e' = (EFfi ("Basis", "bind"), loc)
+ val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
+ val e' = (ECApp (e', t1), loc)
+ val e' = (ECApp (e', t3), loc)
+ val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
+ val e' = (EApp (e', trans1), loc)
+ val e' = (EApp (e', e''), loc)
+ in
+ exp env e'
+ end
+
| EApp (e1, e2) =>
let
val e1 = exp env e1
@@ -424,7 +524,8 @@ fun kindConAndExp (namedC, namedE) =
| ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc)
- | EServerCall (n, es, e, t) => (EServerCall (n, map (exp env) es, exp env e, con env t), loc))
+ | EServerCall (n, es, e, t1, t2) => (EServerCall (n, map (exp env) es, exp env e,
+ con env t1, con env t2), loc))
in
{kind = kind, con = con, exp = exp}
end
diff --git a/src/reduce_local.sml b/src/reduce_local.sml
index 6c25ebf3..9ea5a16d 100644
--- a/src/reduce_local.sml
+++ b/src/reduce_local.sml
@@ -139,7 +139,7 @@ fun exp env (all as (e, loc)) =
| ELet (x, t, e1, e2) => (ELet (x, t, exp env e1, exp (Unknown :: env) e2), loc)
- | EServerCall (n, es, e, t) => (EServerCall (n, map (exp env) es, exp env e, t), loc)
+ | EServerCall (n, es, e, t1, t2) => (EServerCall (n, map (exp env) es, exp env e, t1, t2), loc)
fun reduce file =
let
diff --git a/src/rpcify.sml b/src/rpcify.sml
index 1ed4cd54..75f80940 100644
--- a/src/rpcify.sml
+++ b/src/rpcify.sml
@@ -40,67 +40,22 @@ structure SS = BinarySetFn(struct
val compare = String.compare
end)
-fun multiLiftExpInExp n e =
- if n = 0 then
- e
- else
- multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e)
-
type state = {
- cpsed : int IM.map,
- cpsed_range : con IM.map,
- cps_decls : (string * int * con * exp * string) list,
-
exported : IS.set,
- export_decls : decl list,
-
- maxName : int
+ export_decls : decl list
}
fun frob file =
let
- fun sideish (basis, ssids) e =
- U.Exp.exists {kind = fn _ => false,
- con = fn _ => false,
- exp = fn ENamed n => IS.member (ssids, n)
- | EFfi x => basis x
- | EFfiApp (m, x, _) => basis (m, x)
- | _ => false}
- (U.Exp.map {kind = fn x => x,
- con = fn x => x,
- exp = fn ERecord _ => ERecord []
- | x => x} e)
-
- fun whichIds basis =
- let
- fun decl ((d, _), ssids) =
- let
- val impure = sideish (basis, ssids)
- in
- case d of
- DVal (_, n, _, e, _) => if impure e then
- IS.add (ssids, n)
- else
- ssids
- | DValRec xes => if List.exists (fn (_, _, _, e, _) => impure e) xes then
- foldl (fn ((_, n, _, _, _), ssids) => IS.add (ssids, n))
- ssids xes
- else
- ssids
- | _ => ssids
- end
- in
- foldl decl IS.empty file
- end
-
- val ssids = whichIds Settings.isServerOnly
- val csids = whichIds Settings.isClientOnly
-
- fun sideish' (basis, ids) extra =
- sideish (basis, IM.foldli (fn (id, _, ids) => IS.add (ids, id)) ids extra)
-
- val serverSide = sideish' (Settings.isServerOnly, ssids)
- val clientSide = sideish' (Settings.isClientOnly, csids)
+ val rpcBaseIds = foldl (fn ((d, _), rpcIds) =>
+ case d of
+ DVal (_, n, _, (EFfi ("Basis", "rpc"), _), _) => IS.add (rpcIds, n)
+ | DVal (_, n, _, (ENamed n', _), _) => if IS.member (rpcIds, n') then
+ IS.add (rpcIds, n)
+ else
+ rpcIds
+ | _ => rpcIds)
+ IS.empty file
val tfuncs = foldl
(fn ((d, _), tfuncs) =>
@@ -134,312 +89,50 @@ fun frob file =
fun exp (e, st) =
let
fun getApp (e', args) =
- let
- val loc = #2 e'
- in
- case #1 e' of
- ENamed n => (n, args)
- | EApp (e1, e2) => getApp (e1, e2 :: args)
- | _ => (ErrorMsg.errorAt loc "Mixed client/server code doesn't use a named function for server part";
- (*Print.prefaces "Bad" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))];*)
- (0, []))
- end
-
- fun newRpc (trans1, trans2, st : state) =
- let
- val loc = #2 trans1
-
- 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 ReadWrite, n), loc) :: #export_decls st)
-
- val st = {cpsed = #cpsed st,
- cpsed_range = #cpsed_range st,
- cps_decls = #cps_decls st,
-
- exported = exported,
- export_decls = export_decls,
-
- maxName = #maxName st}
-
- val ran =
- case IM.find (tfuncs, n) of
- NONE => ((*Print.prefaces "BAD" [("e", CorePrint.p_exp CoreEnv.empty (e, loc))];*)
- raise Fail ("Rpcify: Undetected transaction function " ^ Int.toString n))
- | SOME (_, _, ran, _) => ran
-
- val e' = EServerCall (n, args, trans2, ran)
- in
- (e', st)
- end
-
- fun newCps (t1, t2, trans1, trans2, st) =
- let
- val loc = #2 trans1
-
- val (n, args) = getApp (trans1, [])
-
- fun makeCall n' =
+ case e' of
+ ENamed n => SOME (n, args)
+ | EApp (e1, e2) => getApp (#1 e1, e2 :: args)
+ | _ => NONE
+
+ fun newRpc (trans : exp, st : state) =
+ case getApp (#1 trans, []) of
+ NONE => (ErrorMsg.errorAt (#2 trans)
+ "RPC code doesn't use a named function or transaction";
+ (#1 trans, st))
+ | SOME (n, args) =>
+ case IM.find (tfuncs, n) of
+ NONE => ((*Print.prefaces "BAD" [("e", CorePrint.p_exp CoreEnv.empty (e, loc))];*)
+ raise Fail ("Rpcify: Undetected transaction function " ^ Int.toString n))
+ | SOME (_, _, ran, _) =>
let
- val e = (ENamed n', loc)
- val e = (EApp (e, trans2), loc)
+ val loc = #2 trans
+
+ val (exported, export_decls) =
+ if IS.member (#exported st, n) then
+ (#exported st, #export_decls st)
+ else
+ (IS.add (#exported st, n),
+ (DExport (Rpc ReadWrite, n), loc) :: #export_decls st)
+
+ val st = {exported = exported,
+ export_decls = export_decls}
+
+ val k = (ECApp ((EFfi ("Basis", "return"), loc),
+ (CFfi ("Basis", "transaction"), loc)), loc)
+ val k = (ECApp (k, ran), loc)
+ val k = (EApp (k, (EFfi ("Basis", "transaction_monad"), loc)), loc)
+ val e' = EServerCall (n, args, k, ran, ran)
in
- #1 (foldl (fn (arg, e) => (EApp (e, arg), loc)) e args)
+ (e', st)
end
- in
- case IM.find (#cpsed_range st, n) of
- SOME kdom =>
- (case args of
- [] => raise Fail "Rpcify: cps'd function lacks first argument"
- | ke :: args =>
- let
- val ke' = (EFfi ("Basis", "bind"), loc)
- val ke' = (ECApp (ke', (CFfi ("Basis", "transaction"), loc)), loc)
- val ke' = (ECApp (ke', kdom), loc)
- val ke' = (ECApp (ke', t2), loc)
- val ke' = (EApp (ke', (EFfi ("Basis", "transaction_monad"), loc)), loc)
- val ke' = (EApp (ke', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc)
- val ke' = (EApp (ke', E.liftExpInExp 0 trans2), loc)
- val ke' = (EAbs ("x", kdom,
- (CApp ((CFfi ("Basis", "transaction"), loc), t2), loc),
- ke'), loc)
-
- val e' = (ENamed n, loc)
- val e' = (EApp (e', ke'), loc)
- val e' = foldl (fn (arg, e') => (EApp (e', arg), loc)) e' args
- val (e', st) = doExp (e', st)
- in
- (#1 e', st)
- end)
- | NONE =>
- case IM.find (#cpsed st, n) of
- SOME n' => (makeCall n', st)
- | NONE =>
- let
- val (name, fargs, ran, e) =
- case IM.find (tfuncs, n) of
- NONE => (Print.prefaces "BAD" [("e",
- CorePrint.p_exp CoreEnv.empty (e, loc))];
- raise Fail "Rpcify: Undetected transaction function [2]")
- | SOME x => x
-
- val n' = #maxName st
-
- val st = {cpsed = IM.insert (#cpsed st, n, n'),
- cpsed_range = IM.insert (#cpsed_range st, n', ran),
- cps_decls = #cps_decls st,
- exported = #exported st,
- export_decls = #export_decls st,
- maxName = n' + 1}
-
- val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
- val body = (EFfi ("Basis", "bind"), loc)
- val body = (ECApp (body, (CFfi ("Basis", "transaction"), loc)), loc)
- val body = (ECApp (body, t1), loc)
- val body = (ECApp (body, unit), loc)
- val body = (EApp (body, (EFfi ("Basis", "transaction_monad"), loc)), loc)
- val body = (EApp (body, e), loc)
- val body = (EApp (body, (ERel (length args), loc)), loc)
- val bt = (CApp ((CFfi ("Basis", "transaction"), loc), unit), loc)
- val (body, bt) = foldr (fn ((x, t), (body, bt)) =>
- ((EAbs (x, t, bt, body), loc),
- (TFun (t, bt), loc)))
- (body, bt) fargs
- val kt = (TFun (ran, (CApp ((CFfi ("Basis", "transaction"), loc),
- unit),
- loc)), loc)
- val body = (EAbs ("k", kt, bt, body), loc)
- val bt = (TFun (kt, bt), loc)
-
- val (body, st) = doExp (body, st)
-
- val vi = (name ^ "_cps",
- n',
- bt,
- body,
- "")
-
- val st = {cpsed = #cpsed st,
- cpsed_range = #cpsed_range st,
- cps_decls = vi :: #cps_decls st,
- exported = #exported st,
- export_decls = #export_decls st,
- maxName = #maxName st}
- in
- (makeCall n', st)
- end
- end
-
- fun dummyK loc =
- let
- val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
-
- val k = (EFfi ("Basis", "return"), loc)
- val k = (ECApp (k, (CFfi ("Basis", "transaction"), loc)), loc)
- val k = (ECApp (k, unit), loc)
- val k = (EApp (k, (EFfi ("Basis", "transaction_monad"), loc)), loc)
- val k = (EApp (k, (ERecord [], loc)), loc)
- in
- (EAbs ("_", unit, unit, k), loc)
- end
in
case e of
- EApp (
- (EApp
- ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
- (EFfi ("Basis", "transaction_monad"), _)), _),
- (ECase (ed, pes, {disc, ...}), _)), _),
- trans2) =>
- let
- val e' = (EFfi ("Basis", "bind"), loc)
- val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
- val e' = (ECApp (e', t1), loc)
- val e' = (ECApp (e', t2), loc)
- val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
-
- val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
- let
- val e' = (EApp (e', e), loc)
- val e' = (EApp (e',
- multiLiftExpInExp (E.patBindsN p)
- trans2), loc)
- val (e', st) = doExp (e', st)
- in
- ((p, e'), st)
- end) st pes
- in
- (ECase (ed, pes, {disc = disc,
- result = (CApp ((CFfi ("Basis", "transaction"), loc), t2), loc)}),
- st)
- end
-
- | EApp (
- (EApp
- ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
- (EFfi ("Basis", "transaction_monad"), _)), _),
- (EServerCall (n, es, ke, t), _)), _),
- trans2) =>
- let
- val e' = (EFfi ("Basis", "bind"), loc)
- val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
- val e' = (ECApp (e', t), loc)
- val e' = (ECApp (e', t2), loc)
- val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
- val e' = (EApp (e', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc)
- val e' = (EApp (e', E.liftExpInExp 0 trans2), loc)
- val e' = (EAbs ("x", t, t2, e'), loc)
- val e' = (EServerCall (n, es, e', t), loc)
- val (e', st) = doExp (e', st)
- in
- (#1 e', st)
- end
-
- | EApp (
- (EApp
- ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), _), _), t3), _),
- (EFfi ("Basis", "transaction_monad"), _)), _),
- (EApp ((EApp
- ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
- (EFfi ("Basis", "transaction_monad"), _)), _),
- trans1), _), trans2), _)), _),
- trans3) =>
- let
- val e'' = (EFfi ("Basis", "bind"), loc)
- val e'' = (ECApp (e'', (CFfi ("Basis", "transaction"), loc)), loc)
- val e'' = (ECApp (e'', t2), loc)
- val e'' = (ECApp (e'', t3), loc)
- val e'' = (EApp (e'', (EFfi ("Basis", "transaction_monad"), loc)), loc)
- val e'' = (EApp (e'', (EApp (E.liftExpInExp 0 trans2, (ERel 0, loc)), loc)), loc)
- val e'' = (EApp (e'', E.liftExpInExp 0 trans3), loc)
- val e'' = (EAbs ("x", t1, (CApp ((CFfi ("Basis", "transaction"), loc), t3), loc), e''), loc)
-
- val e' = (EFfi ("Basis", "bind"), loc)
- val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
- val e' = (ECApp (e', t1), loc)
- val e' = (ECApp (e', t3), loc)
- val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
- val e' = (EApp (e', trans1), loc)
- val e' = (EApp (e', e''), loc)
- val (e', st) = doExp (e', st)
- in
- (#1 e', st)
- end
-
- | EApp (
- (EApp
- ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), _), _), _), _),
- (EFfi ("Basis", "transaction_monad"), _)), _),
- _), loc),
- (EAbs (_, _, _, (EWrite _, _)), _)) => (e, st)
-
- | EApp (
- (EApp
- ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
- (EFfi ("Basis", "transaction_monad"), _)), _),
- trans1), loc),
- trans2) =>
- (case (serverSide (#cpsed_range st) trans1, clientSide (#cpsed_range st) trans1,
- serverSide (#cpsed_range st) trans2, clientSide (#cpsed_range st) trans2) of
- (true, false, _, true) => newRpc (trans1, trans2, st)
- | (_, true, true, false) =>
- (case #1 trans2 of
- EAbs (x, dom, ran, trans2) =>
- let
- val (trans2, st) = newRpc (trans2, dummyK loc, st)
- val trans2 = (EAbs (x, dom, ran, (trans2, loc)), loc)
-
- val e = (EFfi ("Basis", "bind"), loc)
- val e = (ECApp (e, (CFfi ("Basis", "transaction"), loc)), loc)
- val e = (ECApp (e, t1), loc)
- val e = (ECApp (e, t2), loc)
- val e = (EApp (e, (EFfi ("Basis", "transaction_monad"), loc)), loc)
- val e = (EApp (e, trans1), loc)
- val e = EApp (e, trans2)
- in
- (e, st)
- end
- | _ => (e, st))
- | (true, true, _, _) => newCps (t1, t2, trans1, trans2, st)
-
- | _ => (e, st))
-
- | ERecord xes =>
- let
- val loc = case xes of
- [] => ErrorMsg.dummySpan
- | (_, (_, loc), _) :: _ => loc
-
- fun candidate (x, e) =
- String.isPrefix "On" x
- andalso serverSide (#cpsed_range st) e
- andalso not (clientSide (#cpsed_range st) e)
- in
- if List.exists (fn ((CName x, _), e, _) => candidate (x, e)
- | _ => false) xes then
- let
- val (xes, st) = ListUtil.foldlMap
- (fn (y as (nm as (CName x, _), e, t), st) =>
- if candidate (x, e) then
- let
- val (e, st) = newRpc (e, dummyK loc, st)
- in
- ((nm, (e, loc), t), st)
- end
- else
- (y, st)
- | y => y)
- st xes
- in
- (ERecord xes, st)
- end
- else
- (e, st)
- end
+ EApp ((ECApp ((EFfi ("Basis", "rpc"), _), ran), _), trans) => newRpc (trans, st)
+ | EApp ((ECApp ((ENamed n, _), ran), _), trans) =>
+ if IS.member (rpcBaseIds, n) then
+ newRpc (trans, st)
+ else
+ (e, st)
| _ => (e, st)
end
@@ -456,32 +149,14 @@ fun frob file =
decl = fn x => x}
st d
in
- (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,
- cpsed_range = #cpsed_range st,
- cps_decls = [],
-
- exported = #exported st,
- export_decls = [],
-
- maxName = #maxName st})
+ (#export_decls st @ [d],
+ {exported = #exported st,
+ export_decls = []})
end
val (file, _) = ListUtil.foldlMapConcat decl
- {cpsed = IM.empty,
- cpsed_range = IM.empty,
- cps_decls = [],
-
- exported = IS.empty,
- export_decls = [],
-
- maxName = U.File.maxName file + 1}
+ {exported = IS.empty,
+ export_decls = []}
file
in
file
diff --git a/src/shake.sml b/src/shake.sml
index 4a40d336..e27e9839 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -137,7 +137,7 @@ fun shake file =
in
case e of
ENamed n => check n
- | EServerCall (n, _, _, _) => check n
+ | EServerCall (n, _, _, _, _) => check n
| _ => s
end
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-15 21:29:22 +0000