adamc@607: (* Copyright (c) 2009, Adam Chlipala adamc@607: * All rights reserved. adamc@607: * adamc@607: * Redistribution and use in source and binary forms, with or without adamc@607: * modification, are permitted provided that the following conditions are met: adamc@607: * adamc@607: * - Redistributions of source code must retain the above copyright notice, adamc@607: * this list of conditions and the following disclaimer. adamc@607: * - Redistributions in binary form must reproduce the above copyright notice, adamc@607: * this list of conditions and the following disclaimer in the documentation adamc@607: * and/or other materials provided with the distribution. adamc@607: * - The names of contributors may not be used to endorse or promote products adamc@607: * derived from this software without specific prior written permission. adamc@607: * adamc@607: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@607: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@607: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@607: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@607: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@607: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@607: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@607: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@607: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@607: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@607: * POSSIBILITY OF SUCH DAMAGE. adamc@607: *) adamc@607: adamc@607: structure Rpcify :> RPCIFY = struct adamc@607: adamc@607: open Core adamc@607: adamc@607: structure U = CoreUtil adamc@607: structure E = CoreEnv adamc@607: adamc@607: structure IS = IntBinarySet adamc@607: structure IM = IntBinaryMap adamc@607: adamc@607: structure SS = BinarySetFn(struct adamc@607: type ord_key = string adamc@607: val compare = String.compare adamc@607: end) adamc@607: adamc@642: fun multiLiftExpInExp n e = adamc@642: if n = 0 then adamc@642: e adamc@642: else adamc@642: multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e) adamc@642: adamc@607: val ssBasis = SS.addList (SS.empty, adamc@607: ["requestHeader", adamc@607: "query", adamc@607: "dml", adamc@668: "nextval", adamc@668: "new_channel", adamc@668: "subscribe", adamc@668: "send"]) adamc@607: adamc@607: val csBasis = SS.addList (SS.empty, adamc@607: ["source", adamc@607: "get", adamc@607: "set", adamc@670: "alert", adamc@670: "recv"]) adamc@607: adamc@607: type state = { adamc@608: cpsed : int IM.map, adamc@642: cpsed_range : con IM.map, adamc@608: cps_decls : (string * int * con * exp * string) list, adamc@608: adamc@608: exported : IS.set, adamc@642: export_decls : decl list, adamc@642: adamc@642: maxName : int adamc@607: } adamc@607: adamc@607: fun frob file = adamc@607: let adamc@650: fun sideish (basis, ssids) e = adamc@650: case #1 e of adamc@650: ERecord _ => false adamc@650: | _ => adamc@650: U.Exp.exists {kind = fn _ => false, adamc@650: con = fn _ => false, adamc@650: exp = fn ENamed n => IS.member (ssids, n) adamc@650: | EFfi ("Basis", x) => SS.member (basis, x) adamc@650: | EFfiApp ("Basis", x, _) => SS.member (basis, x) adamc@650: | _ => false} e adamc@607: adamc@607: fun whichIds basis = adamc@607: let adamc@607: fun decl ((d, _), ssids) = adamc@607: let adamc@607: val impure = sideish (basis, ssids) adamc@607: in adamc@607: case d of adamc@607: DVal (_, n, _, e, _) => if impure e then adamc@607: IS.add (ssids, n) adamc@607: else adamc@607: ssids adamc@607: | DValRec xes => if List.exists (fn (_, _, _, e, _) => impure e) xes then adamc@607: foldl (fn ((_, n, _, _, _), ssids) => IS.add (ssids, n)) adamc@607: ssids xes adamc@607: else adamc@607: ssids adamc@607: | _ => ssids adamc@607: end adamc@607: in adamc@607: foldl decl IS.empty file adamc@607: end adamc@607: adamc@607: val ssids = whichIds ssBasis adamc@607: val csids = whichIds csBasis adamc@607: adamc@642: fun sideish' (basis, ids) extra = adamc@642: sideish (basis, IM.foldli (fn (id, _, ids) => IS.add (ids, id)) ids extra) adamc@642: adamc@642: val serverSide = sideish' (ssBasis, ssids) adamc@642: val clientSide = sideish' (csBasis, csids) adamc@607: adamc@609: val tfuncs = foldl adamc@609: (fn ((d, _), tfuncs) => adamc@609: let adamc@642: fun doOne ((x, n, t, e, _), tfuncs) = adamc@609: let adamc@642: val loc = #2 e adamc@642: adamc@642: fun crawl (t, e, args) = adamc@642: case (#1 t, #1 e) of adamc@642: (CApp (_, ran), _) => adamc@642: SOME (x, rev args, ran, e) adamc@642: | (TFun (arg, rest), EAbs (x, _, _, e)) => adamc@642: crawl (rest, e, (x, arg) :: args) adamc@642: | (TFun (arg, rest), _) => adamc@642: crawl (rest, (EApp (e, (ERel (length args), loc)), loc), ("x", arg) :: args) adamc@609: | _ => NONE adamc@609: in adamc@642: case crawl (t, e, []) of adamc@609: NONE => tfuncs adamc@609: | SOME sg => IM.insert (tfuncs, n, sg) adamc@609: end adamc@609: in adamc@609: case d of adamc@609: DVal vi => doOne (vi, tfuncs) adamc@609: | DValRec vis => foldl doOne tfuncs vis adamc@609: | _ => tfuncs adamc@609: end) adamc@609: IM.empty file adamc@609: adamc@607: fun exp (e, st) = adamc@649: let adamc@649: fun getApp (e', args) = adamc@649: let adamc@649: val loc = #2 e' adamc@649: in adamc@642: case #1 e' of adamc@642: ENamed n => (n, args) adamc@642: | EApp (e1, e2) => getApp (e1, e2 :: args) adamc@642: | _ => (ErrorMsg.errorAt loc "Mixed client/server code doesn't use a named function for server part"; adamc@642: Print.prefaces "Bad" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))]; adamc@642: (0, [])) adamc@649: end adamc@642: adamc@649: fun newRpc (trans1, trans2, st : state) = adamc@649: let adamc@649: val loc = #2 trans1 adamc@642: adamc@649: val (n, args) = getApp (trans1, []) adamc@642: adamc@649: val (exported, export_decls) = adamc@649: if IS.member (#exported st, n) then adamc@649: (#exported st, #export_decls st) adamc@649: else adamc@649: (IS.add (#exported st, n), adamc@649: (DExport (Rpc, n), loc) :: #export_decls st) adamc@642: adamc@649: val st = {cpsed = #cpsed st, adamc@649: cpsed_range = #cpsed_range st, adamc@649: cps_decls = #cps_decls st, adamc@642: adamc@649: exported = exported, adamc@649: export_decls = export_decls, adamc@642: adamc@649: maxName = #maxName st} adamc@642: adamc@649: val ran = adamc@649: case IM.find (tfuncs, n) of adamc@649: NONE => (Print.prefaces "BAD" [("e", CorePrint.p_exp CoreEnv.empty (e, loc))]; adamc@649: raise Fail ("Rpcify: Undetected transaction function " ^ Int.toString n)) adamc@649: | SOME (_, _, ran, _) => ran adamc@649: adamc@649: val e' = EServerCall (n, args, trans2, ran) adamc@649: in adamc@649: (e', st) adamc@649: end adamc@651: adamc@651: fun newCps (t1, t2, trans1, trans2, st) = adamc@651: let adamc@651: val loc = #2 trans1 adamc@651: adamc@651: val (n, args) = getApp (trans1, []) adamc@651: adamc@651: fun makeCall n' = adamc@651: let adamc@651: val e = (ENamed n', loc) adamc@651: val e = (EApp (e, trans2), loc) adamc@651: in adamc@651: #1 (foldl (fn (arg, e) => (EApp (e, arg), loc)) e args) adamc@651: end adamc@651: in adamc@651: case IM.find (#cpsed_range st, n) of adamc@651: SOME kdom => adamc@651: (case args of adamc@651: [] => raise Fail "Rpcify: cps'd function lacks first argument" adamc@651: | ke :: args => adamc@651: let adamc@651: val ke' = (EFfi ("Basis", "bind"), loc) adamc@651: val ke' = (ECApp (ke', (CFfi ("Basis", "transaction"), loc)), loc) adamc@651: val ke' = (ECApp (ke', kdom), loc) adamc@651: val ke' = (ECApp (ke', t2), loc) adamc@651: val ke' = (EApp (ke', (EFfi ("Basis", "transaction_monad"), loc)), loc) adamc@651: val ke' = (EApp (ke', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc) adamc@651: val ke' = (EApp (ke', E.liftExpInExp 0 trans2), loc) adamc@651: val ke' = (EAbs ("x", kdom, adamc@651: (CApp ((CFfi ("Basis", "transaction"), loc), t2), loc), adamc@651: ke'), loc) adamc@651: adamc@651: val e' = (ENamed n, loc) adamc@651: val e' = (EApp (e', ke'), loc) adamc@651: val e' = foldl (fn (arg, e') => (EApp (e', arg), loc)) e' args adamc@651: val (e', st) = doExp (e', st) adamc@651: in adamc@651: (#1 e', st) adamc@651: end) adamc@651: | NONE => adamc@651: case IM.find (#cpsed st, n) of adamc@651: SOME n' => (makeCall n', st) adamc@651: | NONE => adamc@651: let adamc@651: val (name, fargs, ran, e) = adamc@651: case IM.find (tfuncs, n) of adamc@651: NONE => (Print.prefaces "BAD" [("e", adamc@651: CorePrint.p_exp CoreEnv.empty (e, loc))]; adamc@651: raise Fail "Rpcify: Undetected transaction function [2]") adamc@651: | SOME x => x adamc@651: adamc@651: val n' = #maxName st adamc@651: adamc@651: val st = {cpsed = IM.insert (#cpsed st, n, n'), adamc@651: cpsed_range = IM.insert (#cpsed_range st, n', ran), adamc@651: cps_decls = #cps_decls st, adamc@651: exported = #exported st, adamc@651: export_decls = #export_decls st, adamc@651: maxName = n' + 1} adamc@651: adamc@651: val unit = (TRecord (CRecord ((KType, loc), []), loc), loc) adamc@651: val body = (EFfi ("Basis", "bind"), loc) adamc@651: val body = (ECApp (body, (CFfi ("Basis", "transaction"), loc)), loc) adamc@651: val body = (ECApp (body, t1), loc) adamc@651: val body = (ECApp (body, unit), loc) adamc@651: val body = (EApp (body, (EFfi ("Basis", "transaction_monad"), loc)), loc) adamc@651: val body = (EApp (body, e), loc) adamc@651: val body = (EApp (body, (ERel (length args), loc)), loc) adamc@651: val bt = (CApp ((CFfi ("Basis", "transaction"), loc), unit), loc) adamc@651: val (body, bt) = foldr (fn ((x, t), (body, bt)) => adamc@651: ((EAbs (x, t, bt, body), loc), adamc@651: (TFun (t, bt), loc))) adamc@651: (body, bt) fargs adamc@651: val kt = (TFun (ran, (CApp ((CFfi ("Basis", "transaction"), loc), adamc@651: unit), adamc@651: loc)), loc) adamc@651: val body = (EAbs ("k", kt, bt, body), loc) adamc@651: val bt = (TFun (kt, bt), loc) adamc@651: adamc@651: val (body, st) = doExp (body, st) adamc@651: adamc@651: val vi = (name ^ "_cps", adamc@651: n', adamc@651: bt, adamc@651: body, adamc@651: "") adamc@651: adamc@651: val st = {cpsed = #cpsed st, adamc@651: cpsed_range = #cpsed_range st, adamc@651: cps_decls = vi :: #cps_decls st, adamc@651: exported = #exported st, adamc@651: export_decls = #export_decls st, adamc@651: maxName = #maxName st} adamc@651: in adamc@651: (makeCall n', st) adamc@651: end adamc@651: end adamc@651: adamc@651: fun dummyK loc = adamc@651: let adamc@651: val unit = (TRecord (CRecord ((KType, loc), []), loc), loc) adamc@651: adamc@651: val k = (EFfi ("Basis", "return"), loc) adamc@651: val k = (ECApp (k, (CFfi ("Basis", "transaction"), loc)), loc) adamc@651: val k = (ECApp (k, unit), loc) adamc@651: val k = (EApp (k, (EFfi ("Basis", "transaction_monad"), loc)), loc) adamc@651: val k = (EApp (k, (ERecord [], loc)), loc) adamc@651: in adamc@651: (EAbs ("_", unit, unit, k), loc) adamc@651: end adamc@649: in adamc@649: case e of adamc@649: EApp ( adamc@649: (EApp adamc@649: ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _), adamc@649: (EFfi ("Basis", "transaction_monad"), _)), _), adamc@649: (ECase (ed, pes, {disc, ...}), _)), _), adamc@649: trans2) => adamc@649: let adamc@649: val e' = (EFfi ("Basis", "bind"), loc) adamc@649: val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) adamc@649: val e' = (ECApp (e', t1), loc) adamc@649: val e' = (ECApp (e', t2), loc) adamc@649: val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) adamc@649: adamc@649: val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) => adamc@649: let adamc@649: val e' = (EApp (e', e), loc) adamc@649: val e' = (EApp (e', adamc@649: multiLiftExpInExp (E.patBindsN p) adamc@649: trans2), loc) adamc@649: val (e', st) = doExp (e', st) adamc@649: in adamc@649: ((p, e'), st) adamc@649: end) st pes adamc@649: in adamc@649: (ECase (ed, pes, {disc = disc, adamc@649: result = (CApp ((CFfi ("Basis", "transaction"), loc), t2), loc)}), adamc@649: st) adamc@649: end adamc@649: adamc@649: | EApp ( adamc@649: (EApp adamc@649: ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _), adamc@649: (EFfi ("Basis", "transaction_monad"), _)), _), adamc@649: (EServerCall (n, es, ke, t), _)), _), adamc@649: trans2) => adamc@649: let adamc@649: val e' = (EFfi ("Basis", "bind"), loc) adamc@649: val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) adamc@649: val e' = (ECApp (e', t), loc) adamc@649: val e' = (ECApp (e', t2), loc) adamc@649: val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) adamc@649: val e' = (EApp (e', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc) adamc@649: val e' = (EApp (e', E.liftExpInExp 0 trans2), loc) adamc@649: val e' = (EAbs ("x", t, t2, e'), loc) adamc@649: val e' = (EServerCall (n, es, e', t), loc) adamc@649: val (e', st) = doExp (e', st) adamc@649: in adamc@649: (#1 e', st) adamc@649: end adamc@649: adamc@649: | EApp ( adamc@649: (EApp adamc@649: ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), _), _), t3), _), adamc@649: (EFfi ("Basis", "transaction_monad"), _)), _), adamc@649: (EApp ((EApp adamc@649: ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _), adamc@649: (EFfi ("Basis", "transaction_monad"), _)), _), adamc@649: trans1), _), trans2), _)), _), adamc@649: trans3) => adamc@649: let adamc@649: val e'' = (EFfi ("Basis", "bind"), loc) adamc@649: val e'' = (ECApp (e'', (CFfi ("Basis", "transaction"), loc)), loc) adamc@649: val e'' = (ECApp (e'', t2), loc) adamc@649: val e'' = (ECApp (e'', t3), loc) adamc@649: val e'' = (EApp (e'', (EFfi ("Basis", "transaction_monad"), loc)), loc) adamc@649: val e'' = (EApp (e'', (EApp (E.liftExpInExp 0 trans2, (ERel 0, loc)), loc)), loc) adamc@649: val e'' = (EApp (e'', E.liftExpInExp 0 trans3), loc) adamc@649: val e'' = (EAbs ("x", t1, (CApp ((CFfi ("Basis", "transaction"), loc), t3), loc), e''), loc) adamc@649: adamc@649: val e' = (EFfi ("Basis", "bind"), loc) adamc@649: val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) adamc@649: val e' = (ECApp (e', t1), loc) adamc@649: val e' = (ECApp (e', t3), loc) adamc@649: val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) adamc@649: val e' = (EApp (e', trans1), loc) adamc@649: val e' = (EApp (e', e''), loc) adamc@649: val (e', st) = doExp (e', st) adamc@649: in adamc@649: (#1 e', st) adamc@649: end adamc@649: adamc@649: | EApp ( adamc@649: (EApp adamc@649: ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), _), _), _), _), adamc@649: (EFfi ("Basis", "transaction_monad"), _)), _), adamc@649: _), loc), adamc@649: (EAbs (_, _, _, (EWrite _, _)), _)) => (e, st) adamc@649: adamc@649: | EApp ( adamc@649: (EApp adamc@649: ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _), adamc@649: (EFfi ("Basis", "transaction_monad"), _)), _), adamc@649: trans1), loc), adamc@649: trans2) => adamc@649: (case (serverSide (#cpsed_range st) trans1, clientSide (#cpsed_range st) trans1, adamc@649: serverSide (#cpsed_range st) trans2, clientSide (#cpsed_range st) trans2) of adamc@649: (true, false, _, true) => newRpc (trans1, trans2, st) adamc@651: | (_, true, true, false) => adamc@651: (case #1 trans2 of adamc@651: EAbs (x, dom, ran, trans2) => adamc@651: let adamc@651: val (trans2, st) = newRpc (trans2, dummyK loc, st) adamc@651: val trans2 = (EAbs (x, dom, ran, (trans2, loc)), loc) adamc@649: adamc@651: val e = (EFfi ("Basis", "bind"), loc) adamc@651: val e = (ECApp (e, (CFfi ("Basis", "transaction"), loc)), loc) adamc@651: val e = (ECApp (e, t1), loc) adamc@651: val e = (ECApp (e, t2), loc) adamc@651: val e = (EApp (e, (EFfi ("Basis", "transaction_monad"), loc)), loc) adamc@651: val e = (EApp (e, trans1), loc) adamc@651: val e = EApp (e, trans2) adamc@651: in adamc@651: (e, st) adamc@651: end adamc@651: | _ => (e, st)) adamc@651: | (true, true, _, _) => newCps (t1, t2, trans1, trans2, st) adamc@649: adamc@649: | _ => (e, st)) adamc@642: adamc@649: | ERecord xes => adamc@649: let adamc@649: val loc = case xes of adamc@649: [] => ErrorMsg.dummySpan adamc@649: | (_, (_, loc), _) :: _ => loc adamc@642: adamc@649: fun candidate (x, e) = adamc@649: String.isPrefix "On" x adamc@649: andalso serverSide (#cpsed_range st) e adamc@649: andalso not (clientSide (#cpsed_range st) e) adamc@649: in adamc@649: if List.exists (fn ((CName x, _), e, _) => candidate (x, e) adamc@649: | _ => false) xes then adamc@649: let adamc@649: val (xes, st) = ListUtil.foldlMap adamc@649: (fn (y as (nm as (CName x, _), e, t), st) => adamc@649: if candidate (x, e) then adamc@649: let adamc@651: val (e, st) = newRpc (e, dummyK loc, st) adamc@649: in adamc@649: ((nm, (e, loc), t), st) adamc@649: end adamc@649: else adamc@649: (y, st) adamc@649: | y => y) adamc@649: st xes adamc@649: in adamc@649: (ERecord xes, st) adamc@649: end adamc@649: else adamc@649: (e, st) adamc@649: end adamc@642: adamc@649: | _ => (e, st) adamc@649: end adamc@607: adamc@642: and doExp (e, st) = U.Exp.foldMap {kind = fn x => x, adamc@642: con = fn x => x, adamc@642: exp = exp} st (ReduceLocal.reduceExp e) adamc@642: adamc@607: fun decl (d, st : state) = adamc@607: let adamc@607: val (d, st) = U.Decl.foldMap {kind = fn x => x, adamc@607: con = fn x => x, adamc@607: exp = exp, adamc@607: decl = fn x => x} adamc@607: st d adamc@607: in adamc@608: (List.revAppend (case #cps_decls st of adamc@608: [] => [d] adamc@608: | ds => adamc@608: case d of adamc@608: (DValRec vis, loc) => [(DValRec (ds @ vis), loc)] adamc@608: | (_, loc) => [d, (DValRec ds, loc)], adamc@608: #export_decls st), adamc@608: {cpsed = #cpsed st, adamc@642: cpsed_range = #cpsed_range st, adamc@608: cps_decls = [], adamc@608: adamc@608: exported = #exported st, adamc@642: export_decls = [], adamc@642: adamc@642: maxName = #maxName st}) adamc@607: end adamc@607: adamc@607: val (file, _) = ListUtil.foldlMapConcat decl adamc@608: {cpsed = IM.empty, adamc@642: cpsed_range = IM.empty, adamc@608: cps_decls = [], adamc@608: adamc@608: exported = IS.empty, adamc@642: export_decls = [], adamc@642: adamc@642: maxName = U.File.maxName file + 1} adamc@607: file adamc@607: in adamc@607: file adamc@607: end adamc@607: adamc@607: end