Mercurial > urweb

annotate src/rpcify.sml @ 956:d80734855790

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Don't try to check if functions are already tail-recursive
author Adam Chlipala <adamc@hcoop.net>
date Thu, 17 Sep 2009 17:17:49 -0400
parents 01a4d936395a
children 2831be2daf2e
rev   line source
adamc@607 1 (* Copyright (c) 2009, Adam Chlipala
adamc@607 2 * All rights reserved.
adamc@607 3 *
adamc@607 4 * Redistribution and use in source and binary forms, with or without
adamc@607 5 * modification, are permitted provided that the following conditions are met:
adamc@607 6 *
adamc@607 7 * - Redistributions of source code must retain the above copyright notice,
adamc@607 8 * this list of conditions and the following disclaimer.
adamc@607 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@607 10 * this list of conditions and the following disclaimer in the documentation
adamc@607 11 * and/or other materials provided with the distribution.
adamc@607 12 * - The names of contributors may not be used to endorse or promote products
adamc@607 13 * derived from this software without specific prior written permission.
adamc@607 14 *
adamc@607 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@607 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@607 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@607 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@607 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@607 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@607 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@607 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@607 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@607 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@607 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@607 26 *)
adamc@607 27
adamc@607 28 structure Rpcify :> RPCIFY = struct
adamc@607 29
adamc@607 30 open Core
adamc@607 31
adamc@607 32 structure U = CoreUtil
adamc@607 33 structure E = CoreEnv
adamc@607 34
adamc@954 35 fun multiLiftExpInExp n e =
adamc@954 36 if n = 0 then
adamc@954 37 e
adamc@954 38 else
adamc@954 39 multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e)
adamc@954 40
adamc@607 41 structure IS = IntBinarySet
adamc@607 42 structure IM = IntBinaryMap
adamc@607 43
adamc@607 44 structure SS = BinarySetFn(struct
adamc@607 45 type ord_key = string
adamc@607 46 val compare = String.compare
adamc@607 47 end)
adamc@607 48
adamc@607 49 type state = {
adamc@608 50 exported : IS.set,
adamc@954 51 export_decls : decl list,
adamc@954 52
adamc@954 53 cpsed : exp' IM.map,
adamc@954 54 rpc : IS.set
adamc@607 55 }
adamc@607 56
adamc@607 57 fun frob file =
adamc@607 58 let
adamc@908 59 val rpcBaseIds = foldl (fn ((d, _), rpcIds) =>
adamc@908 60 case d of
adamc@908 61 DVal (_, n, _, (EFfi ("Basis", "rpc"), _), _) => IS.add (rpcIds, n)
adamc@908 62 | DVal (_, n, _, (ENamed n', _), _) => if IS.member (rpcIds, n') then
adamc@908 63 IS.add (rpcIds, n)
adamc@908 64 else
adamc@908 65 rpcIds
adamc@908 66 | _ => rpcIds)
adamc@908 67 IS.empty file
adamc@607 68
adamc@609 69 val tfuncs = foldl
adamc@609 70 (fn ((d, _), tfuncs) =>
adamc@609 71 let
adamc@642 72 fun doOne ((x, n, t, e, _), tfuncs) =
adamc@609 73 let
adamc@642 74 val loc = #2 e
adamc@642 75
adamc@642 76 fun crawl (t, e, args) =
adamc@642 77 case (#1 t, #1 e) of
adamc@642 78 (CApp (_, ran), _) =>
adamc@642 79 SOME (x, rev args, ran, e)
adamc@642 80 | (TFun (arg, rest), EAbs (x, _, _, e)) =>
adamc@642 81 crawl (rest, e, (x, arg) :: args)
adamc@642 82 | (TFun (arg, rest), _) =>
adamc@642 83 crawl (rest, (EApp (e, (ERel (length args), loc)), loc), ("x", arg) :: args)
adamc@609 84 | _ => NONE
adamc@609 85 in
adamc@642 86 case crawl (t, e, []) of
adamc@609 87 NONE => tfuncs
adamc@609 88 | SOME sg => IM.insert (tfuncs, n, sg)
adamc@609 89 end
adamc@609 90 in
adamc@609 91 case d of
adamc@609 92 DVal vi => doOne (vi, tfuncs)
adamc@609 93 | DValRec vis => foldl doOne tfuncs vis
adamc@609 94 | _ => tfuncs
adamc@609 95 end)
adamc@609 96 IM.empty file
adamc@609 97
adamc@607 98 fun exp (e, st) =
adamc@649 99 let
adamc@649 100 fun getApp (e', args) =
adamc@908 101 case e' of
adamc@908 102 ENamed n => SOME (n, args)
adamc@908 103 | EApp (e1, e2) => getApp (#1 e1, e2 :: args)
adamc@908 104 | _ => NONE
adamc@642 105
adamc@908 106 fun newRpc (trans : exp, st : state) =
adamc@908 107 case getApp (#1 trans, []) of
adamc@908 108 NONE => (ErrorMsg.errorAt (#2 trans)
adamc@908 109 "RPC code doesn't use a named function or transaction";
adamc@908 110 (#1 trans, st))
adamc@908 111 | SOME (n, args) =>
adamc@908 112 case IM.find (tfuncs, n) of
adamc@908 113 NONE => ((*Print.prefaces "BAD" [("e", CorePrint.p_exp CoreEnv.empty (e, loc))];*)
adamc@908 114 raise Fail ("Rpcify: Undetected transaction function " ^ Int.toString n))
adamc@908 115 | SOME (_, _, ran, _) =>
adamc@908 116 let
adamc@908 117 val loc = #2 trans
adamc@642 118
adamc@908 119 val (exported, export_decls) =
adamc@908 120 if IS.member (#exported st, n) then
adamc@908 121 (#exported st, #export_decls st)
adamc@908 122 else
adamc@908 123 (IS.add (#exported st, n),
adamc@908 124 (DExport (Rpc ReadWrite, n), loc) :: #export_decls st)
adamc@642 125
adamc@908 126 val st = {exported = exported,
adamc@954 127 export_decls = export_decls,
adamc@954 128 cpsed = #cpsed st,
adamc@954 129 rpc = #rpc st}
adamc@642 130
adamc@908 131 val k = (ECApp ((EFfi ("Basis", "return"), loc),
adamc@908 132 (CFfi ("Basis", "transaction"), loc)), loc)
adamc@908 133 val k = (ECApp (k, ran), loc)
adamc@908 134 val k = (EApp (k, (EFfi ("Basis", "transaction_monad"), loc)), loc)
adamc@908 135 val e' = EServerCall (n, args, k, ran, ran)
adamc@651 136 in
adamc@908 137 (e', st)
adamc@651 138 end
adamc@649 139 in
adamc@649 140 case e of
adamc@908 141 EApp ((ECApp ((EFfi ("Basis", "rpc"), _), ran), _), trans) => newRpc (trans, st)
adamc@908 142 | EApp ((ECApp ((ENamed n, _), ran), _), trans) =>
adamc@908 143 if IS.member (rpcBaseIds, n) then
adamc@908 144 newRpc (trans, st)
adamc@908 145 else
adamc@908 146 (e, st)
adamc@642 147
adamc@954 148 | ENamed n =>
adamc@954 149 (case IM.find (#cpsed st, n) of
adamc@954 150 NONE => (e, st)
adamc@954 151 | SOME re => (re, st))
adamc@954 152
adamc@649 153 | _ => (e, st)
adamc@649 154 end
adamc@607 155
adamc@642 156 and doExp (e, st) = U.Exp.foldMap {kind = fn x => x,
adamc@642 157 con = fn x => x,
adamc@642 158 exp = exp} st (ReduceLocal.reduceExp e)
adamc@642 159
adamc@607 160 fun decl (d, st : state) =
adamc@607 161 let
adamc@954 162 val makesServerCall = U.Exp.exists {kind = fn _ => false,
adamc@954 163 con = fn _ => false,
adamc@954 164 exp = fn EFfi ("Basis", "rpc") => true
adamc@954 165 | ENamed n => IS.member (#rpc st, n)
adamc@954 166 | _ => false}
adamc@954 167
adamc@954 168 val (d, st) =
adamc@954 169 case #1 d of
adamc@954 170 DValRec vis =>
adamc@954 171 if List.exists (fn (_, _, _, e, _) => makesServerCall e) vis then
adamc@954 172 let
adamc@956 173 val rpc = foldl (fn ((_, n, _, _, _), rpc) =>
adamc@956 174 IS.add (rpc, n)) (#rpc st) vis
adamc@954 175
adamc@956 176 val (cpsed, vis') =
adamc@956 177 foldl (fn (vi as (x, n, t, e, s), (cpsed, vis')) =>
adamc@956 178 let
adamc@956 179 fun getArgs (t, acc) =
adamc@956 180 case #1 t of
adamc@956 181 TFun (dom, ran) =>
adamc@956 182 getArgs (ran, dom :: acc)
adamc@956 183 | _ => (rev acc, t)
adamc@956 184 val (ts, ran) = getArgs (t, [])
adamc@956 185 val ran = case #1 ran of
adamc@956 186 CApp (_, ran) => ran
adamc@956 187 | _ => raise Fail "Rpcify: Tail function not transactional"
adamc@956 188 val len = length ts
adamc@954 189
adamc@956 190 val loc = #2 e
adamc@956 191 val args = ListUtil.mapi
adamc@956 192 (fn (i, _) =>
adamc@956 193 (ERel (len - i - 1), loc))
adamc@956 194 ts
adamc@956 195 val k = (EFfi ("Basis", "return"), loc)
adamc@956 196 val trans = (CFfi ("Basis", "transaction"), loc)
adamc@956 197 val k = (ECApp (k, trans), loc)
adamc@956 198 val k = (ECApp (k, ran), loc)
adamc@956 199 val k = (EApp (k, (EFfi ("Basis", "transaction_monad"),
adamc@956 200 loc)), loc)
adamc@956 201 val re = (ETailCall (n, args, k, ran, ran), loc)
adamc@956 202 val (re, _) = foldr (fn (dom, (re, ran)) =>
adamc@956 203 ((EAbs ("x", dom, ran, re),
adamc@956 204 loc),
adamc@956 205 (TFun (dom, ran), loc)))
adamc@956 206 (re, ran) ts
adamc@954 207
adamc@956 208 val be = multiLiftExpInExp (len + 1) e
adamc@956 209 val be = ListUtil.foldli
adamc@956 210 (fn (i, _, be) =>
adamc@956 211 (EApp (be, (ERel (len - i), loc)), loc))
adamc@956 212 be ts
adamc@956 213 val ne = (EFfi ("Basis", "bind"), loc)
adamc@956 214 val ne = (ECApp (ne, trans), loc)
adamc@956 215 val ne = (ECApp (ne, ran), loc)
adamc@956 216 val unit = (TRecord (CRecord ((KType, loc), []),
adamc@956 217 loc), loc)
adamc@956 218 val ne = (ECApp (ne, unit), loc)
adamc@956 219 val ne = (EApp (ne, (EFfi ("Basis", "transaction_monad"),
adamc@956 220 loc)), loc)
adamc@956 221 val ne = (EApp (ne, be), loc)
adamc@956 222 val ne = (EApp (ne, (ERel 0, loc)), loc)
adamc@956 223 val tunit = (CApp (trans, unit), loc)
adamc@956 224 val kt = (TFun (ran, tunit), loc)
adamc@956 225 val ne = (EAbs ("k", kt, tunit, ne), loc)
adamc@956 226 val (ne, res) = foldr (fn (dom, (ne, ran)) =>
adamc@956 227 ((EAbs ("x", dom, ran, ne), loc),
adamc@956 228 (TFun (dom, ran), loc)))
adamc@956 229 (ne, (TFun (kt, tunit), loc)) ts
adamc@956 230 in
adamc@956 231 (IM.insert (cpsed, n, #1 re),
adamc@956 232 (x, n, res, ne, s) :: vis')
adamc@956 233 end)
adamc@956 234 (#cpsed st, []) vis
adamc@954 235 in
adamc@956 236 ((DValRec (rev vis'), ErrorMsg.dummySpan),
adamc@956 237 {exported = #exported st,
adamc@956 238 export_decls = #export_decls st,
adamc@956 239 cpsed = cpsed,
adamc@956 240 rpc = rpc})
adamc@954 241 end
adamc@954 242 else
adamc@954 243 (d, st)
adamc@954 244 | DVal (x, n, t, e, s) =>
adamc@954 245 (d,
adamc@954 246 {exported = #exported st,
adamc@954 247 export_decls = #export_decls st,
adamc@954 248 cpsed = #cpsed st,
adamc@954 249 rpc = if makesServerCall e then
adamc@954 250 IS.add (#rpc st, n)
adamc@954 251 else
adamc@954 252 #rpc st})
adamc@954 253 | _ => (d, st)
adamc@954 254
adamc@607 255 val (d, st) = U.Decl.foldMap {kind = fn x => x,
adamc@607 256 con = fn x => x,
adamc@607 257 exp = exp,
adamc@607 258 decl = fn x => x}
adamc@607 259 st d
adamc@607 260 in
adamc@908 261 (#export_decls st @ [d],
adamc@908 262 {exported = #exported st,
adamc@954 263 export_decls = [],
adamc@954 264 cpsed = #cpsed st,
adamc@954 265 rpc = #rpc st})
adamc@607 266 end
adamc@607 267
adamc@607 268 val (file, _) = ListUtil.foldlMapConcat decl
adamc@908 269 {exported = IS.empty,
adamc@954 270 export_decls = [],
adamc@954 271 cpsed = IM.empty,
adamc@954 272 rpc = rpcBaseIds}
adamc@607 273 file
adamc@607 274 in
adamc@607 275 file
adamc@607 276 end
adamc@607 277
adamc@607 278 end