Mercurial > urweb

comparison src/tailify.sml @ 957:2831be2daf2e

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