Mercurial > urweb
diff src/rpcify.sml @ 649:96ebc6bdb5a0
Batch example
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 10 Mar 2009 15:17:23 -0400 |
| parents | 4a125bbc602d |
| children | fcf0bd3d1667 |
line wrap: on
line diff
--- a/src/rpcify.sml Tue Mar 10 13:57:09 2009 -0400 +++ b/src/rpcify.sml Tue Mar 10 15:17:23 2009 -0400 @@ -140,242 +140,292 @@ IM.empty file fun exp (e, st) = - 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) => - let - (*val () = Print.prefaces "Default" - [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))]*) - - fun getApp (e', args) = + 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, [])) - in - 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) => - let - val (n, args) = getApp (trans1, []) + end - 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) + fun newRpc (trans1, trans2, st : state) = + let + val loc = #2 trans1 - val st = {cpsed = #cpsed st, - cpsed_range = #cpsed_range st, - cps_decls = #cps_decls st, + val (n, args) = getApp (trans1, []) - exported = exported, - export_decls = export_decls, + 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) - maxName = #maxName st} + val st = {cpsed = #cpsed st, + cpsed_range = #cpsed_range st, + cps_decls = #cps_decls 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 + exported = exported, + export_decls = export_decls, - val e' = EServerCall (n, args, trans2, ran) - in - (EServerCall (n, args, trans2, ran), st) - end - | (true, true, _, _) => - let - val (n, args) = getApp (trans1, []) + maxName = #maxName st} - fun makeCall n' = - let - val e = (ENamed n', loc) - val e = (EApp (e, trans2), loc) - in - #1 (foldl (fn (arg, e) => (EApp (e, arg), loc)) e args) - 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 => + 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 + 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, _, _) => + let + val (n, args) = getApp (trans1, []) + + fun makeCall n' = + let + val e = (ENamed n', loc) + val e = (EApp (e, trans2), loc) + in + #1 (foldl (fn (arg, e) => (EApp (e, arg), loc)) e args) + 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 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 (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 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) + 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 - (#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 + (makeCall n', st) + end + end + | _ => (e, st)) - val n' = #maxName st + | ERecord xes => + let + val loc = case xes of + [] => ErrorMsg.dummySpan + | (_, (_, loc), _) :: _ => loc - 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} + 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 unit = (TRecord (CRecord ((KType, loc), []), loc), loc) - 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 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) + val k = (EAbs ("_", unit, unit, k), loc) - val (body, st) = doExp (body, st) + val (xes, st) = ListUtil.foldlMap + (fn (y as (nm as (CName x, _), e, t), st) => + if candidate (x, e) then + let + val (n, args) = getApp (e, []) - val vi = (name ^ "_cps", - n', - bt, - body, - "") + val (e, st) = newRpc (e, k, st) + in + ((nm, (e, loc), t), st) + end + else + (y, st) + | y => y) + st xes + in + (ERecord xes, st) + end + else + (e, st) + end - 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 - | _ => (e, st) - end - | _ => (e, st) + | _ => (e, st) + end and doExp (e, st) = U.Exp.foldMap {kind = fn x => x, con = fn x => x,