Mercurial > urweb
diff src/rpcify.sml @ 908:ed06e25c70ef
Convert to requiring explicit 'rpc' marker
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sat, 22 Aug 2009 12:55:18 -0400 |
| parents | a28982de5645 |
| children | 2a50da66ffd8 |
line wrap: on
line diff
--- a/src/rpcify.sml Tue Aug 11 12:01:54 2009 -0400 +++ b/src/rpcify.sml Sat Aug 22 12:55:18 2009 -0400 @@ -40,67 +40,22 @@ 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 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 + case e' of + ENamed n => SOME (n, args) + | EApp (e1, e2) => getApp (#1 e1, e2 :: args) + | _ => NONE - fun newRpc (trans1, trans2, st : state) = - let - val loc = #2 trans1 + 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 loc = #2 trans - 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 (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 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' = - let - val e = (ENamed n', loc) - val e = (EApp (e, trans2), loc) + 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 @@ 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