Mercurial > urweb

annotate src/tailify.sml @ 984:815afd323d86

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Whitelisting tags that may be self-closed
author Adam Chlipala <adamc@hcoop.net>
date Sat, 26 Sep 2009 12:45:19 -0400
parents 2831be2daf2e
children
rev   line source
adamc@957 1 (* Copyright (c) 2009, Adam Chlipala
adamc@957 2 * All rights reserved.
adamc@957 3 *
adamc@957 4 * Redistribution and use in source and binary forms, with or without
adamc@957 5 * modification, are permitted provided that the following conditions are met:
adamc@957 6 *
adamc@957 7 * - Redistributions of source code must retain the above copyright notice,
adamc@957 8 * this list of conditions and the following disclaimer.
adamc@957 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@957 10 * this list of conditions and the following disclaimer in the documentation
adamc@957 11 * and/or other materials provided with the distribution.
adamc@957 12 * - The names of contributors may not be used to endorse or promote products
adamc@957 13 * derived from this software without specific prior written permission.
adamc@957 14 *
adamc@957 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@957 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@957 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@957 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@957 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@957 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@957 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@957 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@957 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@957 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@957 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@957 26 *)
adamc@957 27
adamc@957 28 structure Tailify :> TAILIFY = struct
adamc@957 29
adamc@957 30 open Core
adamc@957 31
adamc@957 32 structure U = CoreUtil
adamc@957 33 structure E = CoreEnv
adamc@957 34
adamc@957 35 fun multiLiftExpInExp n e =
adamc@957 36 if n = 0 then
adamc@957 37 e
adamc@957 38 else
adamc@957 39 multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e)
adamc@957 40
adamc@957 41 structure IS = IntBinarySet
adamc@957 42 structure IM = IntBinaryMap
adamc@957 43
adamc@957 44 type state = {
adamc@957 45 cpsed : exp' IM.map,
adamc@957 46 rpc : IS.set
adamc@957 47 }
adamc@957 48
adamc@957 49 fun frob file =
adamc@957 50 let
adamc@957 51 fun exp (e, st : state) =
adamc@957 52 case e of
adamc@957 53 ENamed n =>
adamc@957 54 (case IM.find (#cpsed st, n) of
adamc@957 55 NONE => (e, st)
adamc@957 56 | SOME re => (re, st))
adamc@957 57
adamc@957 58 | _ => (e, st)
adamc@957 59
adamc@957 60 and doExp (e, st) = U.Exp.foldMap {kind = fn x => x,
adamc@957 61 con = fn x => x,
adamc@957 62 exp = exp} st (ReduceLocal.reduceExp e)
adamc@957 63
adamc@957 64 fun decl (d, st : state) =
adamc@957 65 let
adamc@957 66 fun makesServerCall b (e, _) =
adamc@957 67 case e of
adamc@957 68 EServerCall _ => true
adamc@957 69 | ETailCall _ => raise Fail "Tailify: ETailCall too early"
adamc@957 70 | ENamed n => IS.member (#rpc st, n)
adamc@957 71
adamc@957 72 | EPrim _ => false
adamc@957 73 | ERel n => List.nth (b, n)
adamc@957 74 | ECon (_, _, _, NONE) => false
adamc@957 75 | ECon (_, _, _, SOME e) => makesServerCall b e
adamc@957 76 | EFfi _ => false
adamc@957 77 | EFfiApp (_, _, es) => List.exists (makesServerCall b) es
adamc@957 78 | EApp (e1, e2) => makesServerCall b e1 orelse makesServerCall b e2
adamc@957 79 | EAbs (_, _, _, e1) => makesServerCall (false :: b) e1
adamc@957 80 | ECApp (e1, _) => makesServerCall b e1
adamc@957 81 | ECAbs (_, _, e1) => makesServerCall b e1
adamc@957 82
adamc@957 83 | EKAbs (_, e1) => makesServerCall b e1
adamc@957 84 | EKApp (e1, _) => makesServerCall b e1
adamc@957 85
adamc@957 86 | ERecord xes => List.exists (fn ((CName s, _), e, _) =>
adamc@957 87 not (String.isPrefix "On" s) andalso makesServerCall b e
adamc@957 88 | (_, e, _) => makesServerCall b e) xes
adamc@957 89 | EField (e1, _, _) => makesServerCall b e1
adamc@957 90 | EConcat (e1, _, e2, _) => makesServerCall b e1 orelse makesServerCall b e2
adamc@957 91 | ECut (e1, _, _) => makesServerCall b e1
adamc@957 92 | ECutMulti (e1, _, _) => makesServerCall b e1
adamc@957 93
adamc@957 94 | ECase (e1, pes, _) => makesServerCall b e1
adamc@957 95 orelse List.exists (fn (p, e) =>
adamc@957 96 makesServerCall (List.tabulate (E.patBindsN p,
adamc@957 97 fn _ => false) @ b)
adamc@957 98 e) pes
adamc@957 99
adamc@957 100 | EWrite e1 => makesServerCall b e1
adamc@957 101
adamc@957 102 | EClosure (_, es) => List.exists (makesServerCall b) es
adamc@957 103
adamc@957 104 | ELet (_, _, e1, e2) => makesServerCall (makesServerCall b e1 :: b) e2
adamc@957 105
adamc@957 106 val makesServerCall = makesServerCall []
adamc@957 107
adamc@957 108 val (d, st) =
adamc@957 109 case #1 d of
adamc@957 110 DValRec vis =>
adamc@957 111 if List.exists (fn (_, _, _, e, _) => makesServerCall e) vis then
adamc@957 112 let
adamc@957 113 val rpc = foldl (fn ((_, n, _, _, _), rpc) =>
adamc@957 114 IS.add (rpc, n)) (#rpc st) vis
adamc@957 115
adamc@957 116 val (cpsed, vis') =
adamc@957 117 foldl (fn (vi as (x, n, t, e, s), (cpsed, vis')) =>
adamc@957 118 let
adamc@957 119 fun getArgs (t, acc) =
adamc@957 120 case #1 t of
adamc@957 121 TFun (dom, ran) =>
adamc@957 122 getArgs (ran, dom :: acc)
adamc@957 123 | _ => (rev acc, t)
adamc@957 124 val (ts, ran) = getArgs (t, [])
adamc@957 125 val ran = case #1 ran of
adamc@957 126 CApp (_, ran) => ran
adamc@957 127 | _ => raise Fail "Rpcify: Tail function not transactional"
adamc@957 128 val len = length ts
adamc@957 129
adamc@957 130 val loc = #2 e
adamc@957 131 val args = ListUtil.mapi
adamc@957 132 (fn (i, _) =>
adamc@957 133 (ERel (len - i - 1), loc))
adamc@957 134 ts
adamc@957 135 val k = (EFfi ("Basis", "return"), loc)
adamc@957 136 val trans = (CFfi ("Basis", "transaction"), loc)
adamc@957 137 val k = (ECApp (k, trans), loc)
adamc@957 138 val k = (ECApp (k, ran), loc)
adamc@957 139 val k = (EApp (k, (EFfi ("Basis", "transaction_monad"),
adamc@957 140 loc)), loc)
adamc@957 141 val re = (ETailCall (n, args, k, ran, ran), loc)
adamc@957 142 val (re, _) = foldr (fn (dom, (re, ran)) =>
adamc@957 143 ((EAbs ("x", dom, ran, re),
adamc@957 144 loc),
adamc@957 145 (TFun (dom, ran), loc)))
adamc@957 146 (re, ran) ts
adamc@957 147
adamc@957 148 val be = multiLiftExpInExp (len + 1) e
adamc@957 149 val be = ListUtil.foldli
adamc@957 150 (fn (i, _, be) =>
adamc@957 151 (EApp (be, (ERel (len - i), loc)), loc))
adamc@957 152 be ts
adamc@957 153 val ne = (EFfi ("Basis", "bind"), loc)
adamc@957 154 val ne = (ECApp (ne, trans), loc)
adamc@957 155 val ne = (ECApp (ne, ran), loc)
adamc@957 156 val unit = (TRecord (CRecord ((KType, loc), []),
adamc@957 157 loc), loc)
adamc@957 158 val ne = (ECApp (ne, unit), loc)
adamc@957 159 val ne = (EApp (ne, (EFfi ("Basis", "transaction_monad"),
adamc@957 160 loc)), loc)
adamc@957 161 val ne = (EApp (ne, be), loc)
adamc@957 162 val ne = (EApp (ne, (ERel 0, loc)), loc)
adamc@957 163 val tunit = (CApp (trans, unit), loc)
adamc@957 164 val kt = (TFun (ran, tunit), loc)
adamc@957 165 val ne = (EAbs ("k", kt, tunit, ne), loc)
adamc@957 166 val (ne, res) = foldr (fn (dom, (ne, ran)) =>
adamc@957 167 ((EAbs ("x", dom, ran, ne), loc),
adamc@957 168 (TFun (dom, ran), loc)))
adamc@957 169 (ne, (TFun (kt, tunit), loc)) ts
adamc@957 170 in
adamc@957 171 (IM.insert (cpsed, n, #1 re),
adamc@957 172 (x, n, res, ne, s) :: vis')
adamc@957 173 end)
adamc@957 174 (#cpsed st, []) vis
adamc@957 175 in
adamc@957 176 ((DValRec (rev vis'), ErrorMsg.dummySpan),
adamc@957 177 {cpsed = cpsed,
adamc@957 178 rpc = rpc})
adamc@957 179 end
adamc@957 180 else
adamc@957 181 (d, st)
adamc@957 182 | DVal (x, n, t, e, s) =>
adamc@957 183 (d,
adamc@957 184 {cpsed = #cpsed st,
adamc@957 185 rpc = if makesServerCall e then
adamc@957 186 IS.add (#rpc st, n)
adamc@957 187 else
adamc@957 188 #rpc st})
adamc@957 189 | _ => (d, st)
adamc@957 190 in
adamc@957 191 U.Decl.foldMap {kind = fn x => x,
adamc@957 192 con = fn x => x,
adamc@957 193 exp = exp,
adamc@957 194 decl = fn x => x}
adamc@957 195 st d
adamc@957 196 end
adamc@957 197
adamc@957 198 val (file, _) = ListUtil.foldlMap decl
adamc@957 199 {cpsed = IM.empty,
adamc@957 200 rpc = IS.empty}
adamc@957 201 file
adamc@957 202 in
adamc@957 203 file
adamc@957 204 end
adamc@957 205
adamc@957 206 end