Mercurial > urweb

comparison src/rpcify.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 d80734855790
children dfe34fad749d
comparison
equal deleted inserted replaced
956:d80734855790 957:2831be2daf2e
30 open Core 30 open Core
31 31
32 structure U = CoreUtil 32 structure U = CoreUtil
33 structure E = CoreEnv 33 structure E = CoreEnv
34 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 35 structure IS = IntBinarySet
42 structure IM = IntBinaryMap 36 structure IM = IntBinaryMap
43 37
44 structure SS = BinarySetFn(struct
45 type ord_key = string
46 val compare = String.compare
47 end)
48
49 type state = { 38 type state = {
50 exported : IS.set, 39 exported : IS.set,
51 export_decls : decl list, 40 export_decls : decl list
52
53 cpsed : exp' IM.map,
54 rpc : IS.set
55 } 41 }
56 42
57 fun frob file = 43 fun frob file =
58 let 44 let
59 val rpcBaseIds = foldl (fn ((d, _), rpcIds) => 45 val rpcBaseIds = foldl (fn ((d, _), rpcIds) =>
122 else 108 else
123 (IS.add (#exported st, n), 109 (IS.add (#exported st, n),
124 (DExport (Rpc ReadWrite, n), loc) :: #export_decls st) 110 (DExport (Rpc ReadWrite, n), loc) :: #export_decls st)
125 111
126 val st = {exported = exported, 112 val st = {exported = exported,
127 export_decls = export_decls, 113 export_decls = export_decls}
128 cpsed = #cpsed st,
129 rpc = #rpc st}
130 114
131 val k = (ECApp ((EFfi ("Basis", "return"), loc), 115 val k = (ECApp ((EFfi ("Basis", "return"), loc),
132 (CFfi ("Basis", "transaction"), loc)), loc) 116 (CFfi ("Basis", "transaction"), loc)), loc)
133 val k = (ECApp (k, ran), loc) 117 val k = (ECApp (k, ran), loc)
134 val k = (EApp (k, (EFfi ("Basis", "transaction_monad"), loc)), loc) 118 val k = (EApp (k, (EFfi ("Basis", "transaction_monad"), loc)), loc)
143 if IS.member (rpcBaseIds, n) then 127 if IS.member (rpcBaseIds, n) then
144 newRpc (trans, st) 128 newRpc (trans, st)
145 else 129 else
146 (e, st) 130 (e, st)
147 131
148 | ENamed n =>
149 (case IM.find (#cpsed st, n) of
150 NONE => (e, st)
151 | SOME re => (re, st))
152
153 | _ => (e, st) 132 | _ => (e, st)
154 end 133 end
155 134
156 and doExp (e, st) = U.Exp.foldMap {kind = fn x => x, 135 and doExp (e, st) = U.Exp.foldMap {kind = fn x => x,
157 con = fn x => x, 136 con = fn x => x,
158 exp = exp} st (ReduceLocal.reduceExp e) 137 exp = exp} st (ReduceLocal.reduceExp e)
159 138
160 fun decl (d, st : state) = 139 fun decl (d, st : state) =
161 let 140 let
162 val makesServerCall = U.Exp.exists {kind = fn _ => false,
163 con = fn _ => false,
164 exp = fn EFfi ("Basis", "rpc") => true
165 | ENamed n => IS.member (#rpc st, n)
166 | _ => false}
167
168 val (d, st) =
169 case #1 d of
170 DValRec vis =>
171 if List.exists (fn (_, _, _, e, _) => makesServerCall e) vis then
172 let
173 val rpc = foldl (fn ((_, n, _, _, _), rpc) =>
174 IS.add (rpc, n)) (#rpc st) vis
175
176 val (cpsed, vis') =
177 foldl (fn (vi as (x, n, t, e, s), (cpsed, vis')) =>
178 let
179 fun getArgs (t, acc) =
180 case #1 t of
181 TFun (dom, ran) =>
182 getArgs (ran, dom :: acc)
183 | _ => (rev acc, t)
184 val (ts, ran) = getArgs (t, [])
185 val ran = case #1 ran of
186 CApp (_, ran) => ran
187 | _ => raise Fail "Rpcify: Tail function not transactional"
188 val len = length ts
189
190 val loc = #2 e
191 val args = ListUtil.mapi
192 (fn (i, _) =>
193 (ERel (len - i - 1), loc))
194 ts
195 val k = (EFfi ("Basis", "return"), loc)
196 val trans = (CFfi ("Basis", "transaction"), loc)
197 val k = (ECApp (k, trans), loc)
198 val k = (ECApp (k, ran), loc)
199 val k = (EApp (k, (EFfi ("Basis", "transaction_monad"),
200 loc)), loc)
201 val re = (ETailCall (n, args, k, ran, ran), loc)
202 val (re, _) = foldr (fn (dom, (re, ran)) =>
203 ((EAbs ("x", dom, ran, re),
204 loc),
205 (TFun (dom, ran), loc)))
206 (re, ran) ts
207
208 val be = multiLiftExpInExp (len + 1) e
209 val be = ListUtil.foldli
210 (fn (i, _, be) =>
211 (EApp (be, (ERel (len - i), loc)), loc))
212 be ts
213 val ne = (EFfi ("Basis", "bind"), loc)
214 val ne = (ECApp (ne, trans), loc)
215 val ne = (ECApp (ne, ran), loc)
216 val unit = (TRecord (CRecord ((KType, loc), []),
217 loc), loc)
218 val ne = (ECApp (ne, unit), loc)
219 val ne = (EApp (ne, (EFfi ("Basis", "transaction_monad"),
220 loc)), loc)
221 val ne = (EApp (ne, be), loc)
222 val ne = (EApp (ne, (ERel 0, loc)), loc)
223 val tunit = (CApp (trans, unit), loc)
224 val kt = (TFun (ran, tunit), loc)
225 val ne = (EAbs ("k", kt, tunit, ne), loc)
226 val (ne, res) = foldr (fn (dom, (ne, ran)) =>
227 ((EAbs ("x", dom, ran, ne), loc),
228 (TFun (dom, ran), loc)))
229 (ne, (TFun (kt, tunit), loc)) ts
230 in
231 (IM.insert (cpsed, n, #1 re),
232 (x, n, res, ne, s) :: vis')
233 end)
234 (#cpsed st, []) vis
235 in
236 ((DValRec (rev vis'), ErrorMsg.dummySpan),
237 {exported = #exported st,
238 export_decls = #export_decls st,
239 cpsed = cpsed,
240 rpc = rpc})
241 end
242 else
243 (d, st)
244 | DVal (x, n, t, e, s) =>
245 (d,
246 {exported = #exported st,
247 export_decls = #export_decls st,
248 cpsed = #cpsed st,
249 rpc = if makesServerCall e then
250 IS.add (#rpc st, n)
251 else
252 #rpc st})
253 | _ => (d, st)
254
255 val (d, st) = U.Decl.foldMap {kind = fn x => x, 141 val (d, st) = U.Decl.foldMap {kind = fn x => x,
256 con = fn x => x, 142 con = fn x => x,
257 exp = exp, 143 exp = exp,
258 decl = fn x => x} 144 decl = fn x => x}
259 st d 145 st d
260 in 146 in
261 (#export_decls st @ [d], 147 (#export_decls st @ [d],
262 {exported = #exported st, 148 {exported = #exported st,
263 export_decls = [], 149 export_decls = []})
264 cpsed = #cpsed st,
265 rpc = #rpc st})
266 end 150 end
267 151
268 val (file, _) = ListUtil.foldlMapConcat decl 152 val (file, _) = ListUtil.foldlMapConcat decl
269 {exported = IS.empty, 153 {exported = IS.empty,
270 export_decls = [], 154 export_decls = []}
271 cpsed = IM.empty,
272 rpc = rpcBaseIds}
273 file 155 file
274 in 156 in
275 file 157 file
276 end 158 end
277 159