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@954: fun multiLiftExpInExp n e = adamc@954: if n = 0 then adamc@954: e adamc@954: else adamc@954: multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e) adamc@954: 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@607: type state = { adamc@608: exported : IS.set, adamc@954: export_decls : decl list, adamc@954: adamc@954: cpsed : exp' IM.map, adamc@954: rpc : IS.set adamc@607: } adamc@607: adamc@607: fun frob file = adamc@607: let adamc@908: val rpcBaseIds = foldl (fn ((d, _), rpcIds) => adamc@908: case d of adamc@908: DVal (_, n, _, (EFfi ("Basis", "rpc"), _), _) => IS.add (rpcIds, n) adamc@908: | DVal (_, n, _, (ENamed n', _), _) => if IS.member (rpcIds, n') then adamc@908: IS.add (rpcIds, n) adamc@908: else adamc@908: rpcIds adamc@908: | _ => rpcIds) adamc@908: IS.empty file 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@908: case e' of adamc@908: ENamed n => SOME (n, args) adamc@908: | EApp (e1, e2) => getApp (#1 e1, e2 :: args) adamc@908: | _ => NONE adamc@642: adamc@908: fun newRpc (trans : exp, st : state) = adamc@908: case getApp (#1 trans, []) of adamc@908: NONE => (ErrorMsg.errorAt (#2 trans) adamc@908: "RPC code doesn't use a named function or transaction"; adamc@908: (#1 trans, st)) adamc@908: | SOME (n, args) => adamc@908: case IM.find (tfuncs, n) of adamc@908: NONE => ((*Print.prefaces "BAD" [("e", CorePrint.p_exp CoreEnv.empty (e, loc))];*) adamc@908: raise Fail ("Rpcify: Undetected transaction function " ^ Int.toString n)) adamc@908: | SOME (_, _, ran, _) => adamc@908: let adamc@908: val loc = #2 trans adamc@642: adamc@908: val (exported, export_decls) = adamc@908: if IS.member (#exported st, n) then adamc@908: (#exported st, #export_decls st) adamc@908: else adamc@908: (IS.add (#exported st, n), adamc@908: (DExport (Rpc ReadWrite, n), loc) :: #export_decls st) adamc@642: adamc@908: val st = {exported = exported, adamc@954: export_decls = export_decls, adamc@954: cpsed = #cpsed st, adamc@954: rpc = #rpc st} adamc@642: adamc@908: val k = (ECApp ((EFfi ("Basis", "return"), loc), adamc@908: (CFfi ("Basis", "transaction"), loc)), loc) adamc@908: val k = (ECApp (k, ran), loc) adamc@908: val k = (EApp (k, (EFfi ("Basis", "transaction_monad"), loc)), loc) adamc@908: val e' = EServerCall (n, args, k, ran, ran) adamc@651: in adamc@908: (e', st) adamc@651: end adamc@649: in adamc@649: case e of adamc@908: EApp ((ECApp ((EFfi ("Basis", "rpc"), _), ran), _), trans) => newRpc (trans, st) adamc@908: | EApp ((ECApp ((ENamed n, _), ran), _), trans) => adamc@908: if IS.member (rpcBaseIds, n) then adamc@908: newRpc (trans, st) adamc@908: else adamc@908: (e, st) adamc@642: adamc@954: | ENamed n => adamc@954: (case IM.find (#cpsed st, n) of adamc@954: NONE => (e, st) adamc@954: | SOME re => (re, st)) adamc@954: 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@954: val makesServerCall = U.Exp.exists {kind = fn _ => false, adamc@954: con = fn _ => false, adamc@954: exp = fn EFfi ("Basis", "rpc") => true adamc@954: | ENamed n => IS.member (#rpc st, n) adamc@954: | _ => false} adamc@954: adamc@954: val (d, st) = adamc@954: case #1 d of adamc@954: DValRec vis => adamc@954: if List.exists (fn (_, _, _, e, _) => makesServerCall e) vis then adamc@954: let adamc@956: val rpc = foldl (fn ((_, n, _, _, _), rpc) => adamc@956: IS.add (rpc, n)) (#rpc st) vis adamc@954: adamc@956: val (cpsed, vis') = adamc@956: foldl (fn (vi as (x, n, t, e, s), (cpsed, vis')) => adamc@956: let adamc@956: fun getArgs (t, acc) = adamc@956: case #1 t of adamc@956: TFun (dom, ran) => adamc@956: getArgs (ran, dom :: acc) adamc@956: | _ => (rev acc, t) adamc@956: val (ts, ran) = getArgs (t, []) adamc@956: val ran = case #1 ran of adamc@956: CApp (_, ran) => ran adamc@956: | _ => raise Fail "Rpcify: Tail function not transactional" adamc@956: val len = length ts adamc@954: adamc@956: val loc = #2 e adamc@956: val args = ListUtil.mapi adamc@956: (fn (i, _) => adamc@956: (ERel (len - i - 1), loc)) adamc@956: ts adamc@956: val k = (EFfi ("Basis", "return"), loc) adamc@956: val trans = (CFfi ("Basis", "transaction"), loc) adamc@956: val k = (ECApp (k, trans), loc) adamc@956: val k = (ECApp (k, ran), loc) adamc@956: val k = (EApp (k, (EFfi ("Basis", "transaction_monad"), adamc@956: loc)), loc) adamc@956: val re = (ETailCall (n, args, k, ran, ran), loc) adamc@956: val (re, _) = foldr (fn (dom, (re, ran)) => adamc@956: ((EAbs ("x", dom, ran, re), adamc@956: loc), adamc@956: (TFun (dom, ran), loc))) adamc@956: (re, ran) ts adamc@954: adamc@956: val be = multiLiftExpInExp (len + 1) e adamc@956: val be = ListUtil.foldli adamc@956: (fn (i, _, be) => adamc@956: (EApp (be, (ERel (len - i), loc)), loc)) adamc@956: be ts adamc@956: val ne = (EFfi ("Basis", "bind"), loc) adamc@956: val ne = (ECApp (ne, trans), loc) adamc@956: val ne = (ECApp (ne, ran), loc) adamc@956: val unit = (TRecord (CRecord ((KType, loc), []), adamc@956: loc), loc) adamc@956: val ne = (ECApp (ne, unit), loc) adamc@956: val ne = (EApp (ne, (EFfi ("Basis", "transaction_monad"), adamc@956: loc)), loc) adamc@956: val ne = (EApp (ne, be), loc) adamc@956: val ne = (EApp (ne, (ERel 0, loc)), loc) adamc@956: val tunit = (CApp (trans, unit), loc) adamc@956: val kt = (TFun (ran, tunit), loc) adamc@956: val ne = (EAbs ("k", kt, tunit, ne), loc) adamc@956: val (ne, res) = foldr (fn (dom, (ne, ran)) => adamc@956: ((EAbs ("x", dom, ran, ne), loc), adamc@956: (TFun (dom, ran), loc))) adamc@956: (ne, (TFun (kt, tunit), loc)) ts adamc@956: in adamc@956: (IM.insert (cpsed, n, #1 re), adamc@956: (x, n, res, ne, s) :: vis') adamc@956: end) adamc@956: (#cpsed st, []) vis adamc@954: in adamc@956: ((DValRec (rev vis'), ErrorMsg.dummySpan), adamc@956: {exported = #exported st, adamc@956: export_decls = #export_decls st, adamc@956: cpsed = cpsed, adamc@956: rpc = rpc}) adamc@954: end adamc@954: else adamc@954: (d, st) adamc@954: | DVal (x, n, t, e, s) => adamc@954: (d, adamc@954: {exported = #exported st, adamc@954: export_decls = #export_decls st, adamc@954: cpsed = #cpsed st, adamc@954: rpc = if makesServerCall e then adamc@954: IS.add (#rpc st, n) adamc@954: else adamc@954: #rpc st}) adamc@954: | _ => (d, st) adamc@954: 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@908: (#export_decls st @ [d], adamc@908: {exported = #exported st, adamc@954: export_decls = [], adamc@954: cpsed = #cpsed st, adamc@954: rpc = #rpc st}) adamc@607: end adamc@607: adamc@607: val (file, _) = ListUtil.foldlMapConcat decl adamc@908: {exported = IS.empty, adamc@954: export_decls = [], adamc@954: cpsed = IM.empty, adamc@954: rpc = rpcBaseIds} adamc@607: file adamc@607: in adamc@607: file adamc@607: end adamc@607: adamc@607: end