Mercurial > urweb
comparison src/rpcify.sml @ 957:2831be2daf2e
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 |