adamc@957: (* Copyright (c) 2009, Adam Chlipala adamc@957: * All rights reserved. adamc@957: * adamc@957: * Redistribution and use in source and binary forms, with or without adamc@957: * modification, are permitted provided that the following conditions are met: adamc@957: * adamc@957: * - Redistributions of source code must retain the above copyright notice, adamc@957: * this list of conditions and the following disclaimer. adamc@957: * - Redistributions in binary form must reproduce the above copyright notice, adamc@957: * this list of conditions and the following disclaimer in the documentation adamc@957: * and/or other materials provided with the distribution. adamc@957: * - The names of contributors may not be used to endorse or promote products adamc@957: * derived from this software without specific prior written permission. adamc@957: * adamc@957: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@957: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@957: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@957: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@957: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@957: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@957: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@957: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@957: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@957: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@957: * POSSIBILITY OF SUCH DAMAGE. adamc@957: *) adamc@957: adamc@957: structure Tailify :> TAILIFY = struct adamc@957: adamc@957: open Core adamc@957: adamc@957: structure U = CoreUtil adamc@957: structure E = CoreEnv adamc@957: adamc@957: fun multiLiftExpInExp n e = adamc@957: if n = 0 then adamc@957: e adamc@957: else adamc@957: multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e) adamc@957: adamc@957: structure IS = IntBinarySet adamc@957: structure IM = IntBinaryMap adamc@957: adamc@957: type state = { adamc@957: cpsed : exp' IM.map, adamc@957: rpc : IS.set adamc@957: } adamc@957: adamc@957: fun frob file = adamc@957: let adamc@957: fun exp (e, st : state) = adamc@957: case e of adamc@957: ENamed n => adamc@957: (case IM.find (#cpsed st, n) of adamc@957: NONE => (e, st) adamc@957: | SOME re => (re, st)) adamc@957: adamc@957: | _ => (e, st) adamc@957: adamc@957: and doExp (e, st) = U.Exp.foldMap {kind = fn x => x, adamc@957: con = fn x => x, adamc@957: exp = exp} st (ReduceLocal.reduceExp e) adamc@957: adamc@957: fun decl (d, st : state) = adamc@957: let adamc@957: fun makesServerCall b (e, _) = adamc@957: case e of adamc@957: EServerCall _ => true adamc@957: | ETailCall _ => raise Fail "Tailify: ETailCall too early" adamc@957: | ENamed n => IS.member (#rpc st, n) adamc@957: adamc@957: | EPrim _ => false adamc@957: | ERel n => List.nth (b, n) adamc@957: | ECon (_, _, _, NONE) => false adamc@957: | ECon (_, _, _, SOME e) => makesServerCall b e adamc@957: | EFfi _ => false adamc@957: | EFfiApp (_, _, es) => List.exists (makesServerCall b) es adamc@957: | EApp (e1, e2) => makesServerCall b e1 orelse makesServerCall b e2 adamc@957: | EAbs (_, _, _, e1) => makesServerCall (false :: b) e1 adamc@957: | ECApp (e1, _) => makesServerCall b e1 adamc@957: | ECAbs (_, _, e1) => makesServerCall b e1 adamc@957: adamc@957: | EKAbs (_, e1) => makesServerCall b e1 adamc@957: | EKApp (e1, _) => makesServerCall b e1 adamc@957: adamc@957: | ERecord xes => List.exists (fn ((CName s, _), e, _) => adamc@957: not (String.isPrefix "On" s) andalso makesServerCall b e adamc@957: | (_, e, _) => makesServerCall b e) xes adamc@957: | EField (e1, _, _) => makesServerCall b e1 adamc@957: | EConcat (e1, _, e2, _) => makesServerCall b e1 orelse makesServerCall b e2 adamc@957: | ECut (e1, _, _) => makesServerCall b e1 adamc@957: | ECutMulti (e1, _, _) => makesServerCall b e1 adamc@957: adamc@957: | ECase (e1, pes, _) => makesServerCall b e1 adamc@957: orelse List.exists (fn (p, e) => adamc@957: makesServerCall (List.tabulate (E.patBindsN p, adamc@957: fn _ => false) @ b) adamc@957: e) pes adamc@957: adamc@957: | EWrite e1 => makesServerCall b e1 adamc@957: adamc@957: | EClosure (_, es) => List.exists (makesServerCall b) es adamc@957: adamc@957: | ELet (_, _, e1, e2) => makesServerCall (makesServerCall b e1 :: b) e2 adamc@957: adamc@957: val makesServerCall = makesServerCall [] adamc@957: adamc@957: val (d, st) = adamc@957: case #1 d of adamc@957: DValRec vis => adamc@957: if List.exists (fn (_, _, _, e, _) => makesServerCall e) vis then adamc@957: let adamc@957: val rpc = foldl (fn ((_, n, _, _, _), rpc) => adamc@957: IS.add (rpc, n)) (#rpc st) vis adamc@957: adamc@957: val (cpsed, vis') = adamc@957: foldl (fn (vi as (x, n, t, e, s), (cpsed, vis')) => adamc@957: let adamc@957: fun getArgs (t, acc) = adamc@957: case #1 t of adamc@957: TFun (dom, ran) => adamc@957: getArgs (ran, dom :: acc) adamc@957: | _ => (rev acc, t) adamc@957: val (ts, ran) = getArgs (t, []) adamc@957: val ran = case #1 ran of adamc@957: CApp (_, ran) => ran adamc@957: | _ => raise Fail "Rpcify: Tail function not transactional" adamc@957: val len = length ts adamc@957: adamc@957: val loc = #2 e adamc@957: val args = ListUtil.mapi adamc@957: (fn (i, _) => adamc@957: (ERel (len - i - 1), loc)) adamc@957: ts adamc@957: val k = (EFfi ("Basis", "return"), loc) adamc@957: val trans = (CFfi ("Basis", "transaction"), loc) adamc@957: val k = (ECApp (k, trans), loc) adamc@957: val k = (ECApp (k, ran), loc) adamc@957: val k = (EApp (k, (EFfi ("Basis", "transaction_monad"), adamc@957: loc)), loc) adamc@957: val re = (ETailCall (n, args, k, ran, ran), loc) adamc@957: val (re, _) = foldr (fn (dom, (re, ran)) => adamc@957: ((EAbs ("x", dom, ran, re), adamc@957: loc), adamc@957: (TFun (dom, ran), loc))) adamc@957: (re, ran) ts adamc@957: adamc@957: val be = multiLiftExpInExp (len + 1) e adamc@957: val be = ListUtil.foldli adamc@957: (fn (i, _, be) => adamc@957: (EApp (be, (ERel (len - i), loc)), loc)) adamc@957: be ts adamc@957: val ne = (EFfi ("Basis", "bind"), loc) adamc@957: val ne = (ECApp (ne, trans), loc) adamc@957: val ne = (ECApp (ne, ran), loc) adamc@957: val unit = (TRecord (CRecord ((KType, loc), []), adamc@957: loc), loc) adamc@957: val ne = (ECApp (ne, unit), loc) adamc@957: val ne = (EApp (ne, (EFfi ("Basis", "transaction_monad"), adamc@957: loc)), loc) adamc@957: val ne = (EApp (ne, be), loc) adamc@957: val ne = (EApp (ne, (ERel 0, loc)), loc) adamc@957: val tunit = (CApp (trans, unit), loc) adamc@957: val kt = (TFun (ran, tunit), loc) adamc@957: val ne = (EAbs ("k", kt, tunit, ne), loc) adamc@957: val (ne, res) = foldr (fn (dom, (ne, ran)) => adamc@957: ((EAbs ("x", dom, ran, ne), loc), adamc@957: (TFun (dom, ran), loc))) adamc@957: (ne, (TFun (kt, tunit), loc)) ts adamc@957: in adamc@957: (IM.insert (cpsed, n, #1 re), adamc@957: (x, n, res, ne, s) :: vis') adamc@957: end) adamc@957: (#cpsed st, []) vis adamc@957: in adamc@957: ((DValRec (rev vis'), ErrorMsg.dummySpan), adamc@957: {cpsed = cpsed, adamc@957: rpc = rpc}) adamc@957: end adamc@957: else adamc@957: (d, st) adamc@957: | DVal (x, n, t, e, s) => adamc@957: (d, adamc@957: {cpsed = #cpsed st, adamc@957: rpc = if makesServerCall e then adamc@957: IS.add (#rpc st, n) adamc@957: else adamc@957: #rpc st}) adamc@957: | _ => (d, st) adamc@957: in adamc@957: U.Decl.foldMap {kind = fn x => x, adamc@957: con = fn x => x, adamc@957: exp = exp, adamc@957: decl = fn x => x} adamc@957: st d adamc@957: end adamc@957: adamc@957: val (file, _) = ListUtil.foldlMap decl adamc@957: {cpsed = IM.empty, adamc@957: rpc = IS.empty} adamc@957: file adamc@957: in adamc@957: file adamc@957: end adamc@957: adamc@957: end