From f79732bbf16467ecf40c6068bac93502aa49e9d2 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 22 Aug 2009 12:55:18 -0400 Subject: Convert to requiring explicit 'rpc' marker --- src/core.sml | 2 +- src/core_print.sml | 16 +- src/core_util.sml | 12 +- src/effectize.sml | 4 +- src/monoize.sml | 5 +- src/reduce.sml | 103 +++++++++++- src/reduce_local.sml | 2 +- src/rpcify.sml | 433 +++++++-------------------------------------------- src/shake.sml | 2 +- 9 files changed, 180 insertions(+), 399 deletions(-) (limited to 'src') 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 -- cgit v1.2.3