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@607
|
35 structure IS = IntBinarySet
|
adamc@607
|
36 structure IM = IntBinaryMap
|
adamc@607
|
37
|
adamc@607
|
38 structure SS = BinarySetFn(struct
|
adamc@607
|
39 type ord_key = string
|
adamc@607
|
40 val compare = String.compare
|
adamc@607
|
41 end)
|
adamc@607
|
42
|
adamc@642
|
43 fun multiLiftExpInExp n e =
|
adamc@642
|
44 if n = 0 then
|
adamc@642
|
45 e
|
adamc@642
|
46 else
|
adamc@642
|
47 multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e)
|
adamc@642
|
48
|
adamc@607
|
49 val ssBasis = SS.addList (SS.empty,
|
adamc@607
|
50 ["requestHeader",
|
adamc@607
|
51 "query",
|
adamc@607
|
52 "dml",
|
adamc@607
|
53 "nextval"])
|
adamc@607
|
54
|
adamc@607
|
55 val csBasis = SS.addList (SS.empty,
|
adamc@607
|
56 ["source",
|
adamc@607
|
57 "get",
|
adamc@607
|
58 "set",
|
adamc@607
|
59 "alert"])
|
adamc@607
|
60
|
adamc@607
|
61 type state = {
|
adamc@608
|
62 cpsed : int IM.map,
|
adamc@642
|
63 cpsed_range : con IM.map,
|
adamc@608
|
64 cps_decls : (string * int * con * exp * string) list,
|
adamc@608
|
65
|
adamc@608
|
66 exported : IS.set,
|
adamc@642
|
67 export_decls : decl list,
|
adamc@642
|
68
|
adamc@642
|
69 maxName : int
|
adamc@607
|
70 }
|
adamc@607
|
71
|
adamc@607
|
72 fun frob file =
|
adamc@607
|
73 let
|
adamc@607
|
74 fun sideish (basis, ssids) =
|
adamc@607
|
75 U.Exp.exists {kind = fn _ => false,
|
adamc@607
|
76 con = fn _ => false,
|
adamc@607
|
77 exp = fn ENamed n => IS.member (ssids, n)
|
adamc@607
|
78 | EFfi ("Basis", x) => SS.member (basis, x)
|
adamc@607
|
79 | EFfiApp ("Basis", x, _) => SS.member (basis, x)
|
adamc@607
|
80 | _ => false}
|
adamc@607
|
81
|
adamc@607
|
82 fun whichIds basis =
|
adamc@607
|
83 let
|
adamc@607
|
84 fun decl ((d, _), ssids) =
|
adamc@607
|
85 let
|
adamc@607
|
86 val impure = sideish (basis, ssids)
|
adamc@607
|
87 in
|
adamc@607
|
88 case d of
|
adamc@607
|
89 DVal (_, n, _, e, _) => if impure e then
|
adamc@607
|
90 IS.add (ssids, n)
|
adamc@607
|
91 else
|
adamc@607
|
92 ssids
|
adamc@607
|
93 | DValRec xes => if List.exists (fn (_, _, _, e, _) => impure e) xes then
|
adamc@607
|
94 foldl (fn ((_, n, _, _, _), ssids) => IS.add (ssids, n))
|
adamc@607
|
95 ssids xes
|
adamc@607
|
96 else
|
adamc@607
|
97 ssids
|
adamc@607
|
98 | _ => ssids
|
adamc@607
|
99 end
|
adamc@607
|
100 in
|
adamc@607
|
101 foldl decl IS.empty file
|
adamc@607
|
102 end
|
adamc@607
|
103
|
adamc@607
|
104 val ssids = whichIds ssBasis
|
adamc@607
|
105 val csids = whichIds csBasis
|
adamc@607
|
106
|
adamc@642
|
107 fun sideish' (basis, ids) extra =
|
adamc@642
|
108 sideish (basis, IM.foldli (fn (id, _, ids) => IS.add (ids, id)) ids extra)
|
adamc@642
|
109
|
adamc@642
|
110 val serverSide = sideish' (ssBasis, ssids)
|
adamc@642
|
111 val clientSide = sideish' (csBasis, csids)
|
adamc@607
|
112
|
adamc@609
|
113 val tfuncs = foldl
|
adamc@609
|
114 (fn ((d, _), tfuncs) =>
|
adamc@609
|
115 let
|
adamc@642
|
116 fun doOne ((x, n, t, e, _), tfuncs) =
|
adamc@609
|
117 let
|
adamc@642
|
118 val loc = #2 e
|
adamc@642
|
119
|
adamc@642
|
120 fun crawl (t, e, args) =
|
adamc@642
|
121 case (#1 t, #1 e) of
|
adamc@642
|
122 (CApp (_, ran), _) =>
|
adamc@642
|
123 SOME (x, rev args, ran, e)
|
adamc@642
|
124 | (TFun (arg, rest), EAbs (x, _, _, e)) =>
|
adamc@642
|
125 crawl (rest, e, (x, arg) :: args)
|
adamc@642
|
126 | (TFun (arg, rest), _) =>
|
adamc@642
|
127 crawl (rest, (EApp (e, (ERel (length args), loc)), loc), ("x", arg) :: args)
|
adamc@609
|
128 | _ => NONE
|
adamc@609
|
129 in
|
adamc@642
|
130 case crawl (t, e, []) of
|
adamc@609
|
131 NONE => tfuncs
|
adamc@609
|
132 | SOME sg => IM.insert (tfuncs, n, sg)
|
adamc@609
|
133 end
|
adamc@609
|
134 in
|
adamc@609
|
135 case d of
|
adamc@609
|
136 DVal vi => doOne (vi, tfuncs)
|
adamc@609
|
137 | DValRec vis => foldl doOne tfuncs vis
|
adamc@609
|
138 | _ => tfuncs
|
adamc@609
|
139 end)
|
adamc@609
|
140 IM.empty file
|
adamc@609
|
141
|
adamc@607
|
142 fun exp (e, st) =
|
adamc@649
|
143 let
|
adamc@649
|
144 fun getApp (e', args) =
|
adamc@649
|
145 let
|
adamc@649
|
146 val loc = #2 e'
|
adamc@649
|
147 in
|
adamc@642
|
148 case #1 e' of
|
adamc@642
|
149 ENamed n => (n, args)
|
adamc@642
|
150 | EApp (e1, e2) => getApp (e1, e2 :: args)
|
adamc@642
|
151 | _ => (ErrorMsg.errorAt loc "Mixed client/server code doesn't use a named function for server part";
|
adamc@642
|
152 Print.prefaces "Bad" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))];
|
adamc@642
|
153 (0, []))
|
adamc@649
|
154 end
|
adamc@642
|
155
|
adamc@649
|
156 fun newRpc (trans1, trans2, st : state) =
|
adamc@649
|
157 let
|
adamc@649
|
158 val loc = #2 trans1
|
adamc@642
|
159
|
adamc@649
|
160 val (n, args) = getApp (trans1, [])
|
adamc@642
|
161
|
adamc@649
|
162 val (exported, export_decls) =
|
adamc@649
|
163 if IS.member (#exported st, n) then
|
adamc@649
|
164 (#exported st, #export_decls st)
|
adamc@649
|
165 else
|
adamc@649
|
166 (IS.add (#exported st, n),
|
adamc@649
|
167 (DExport (Rpc, n), loc) :: #export_decls st)
|
adamc@642
|
168
|
adamc@649
|
169 val st = {cpsed = #cpsed st,
|
adamc@649
|
170 cpsed_range = #cpsed_range st,
|
adamc@649
|
171 cps_decls = #cps_decls st,
|
adamc@642
|
172
|
adamc@649
|
173 exported = exported,
|
adamc@649
|
174 export_decls = export_decls,
|
adamc@642
|
175
|
adamc@649
|
176 maxName = #maxName st}
|
adamc@642
|
177
|
adamc@649
|
178 val ran =
|
adamc@649
|
179 case IM.find (tfuncs, n) of
|
adamc@649
|
180 NONE => (Print.prefaces "BAD" [("e", CorePrint.p_exp CoreEnv.empty (e, loc))];
|
adamc@649
|
181 raise Fail ("Rpcify: Undetected transaction function " ^ Int.toString n))
|
adamc@649
|
182 | SOME (_, _, ran, _) => ran
|
adamc@649
|
183
|
adamc@649
|
184 val e' = EServerCall (n, args, trans2, ran)
|
adamc@649
|
185 in
|
adamc@649
|
186 (e', st)
|
adamc@649
|
187 end
|
adamc@649
|
188 in
|
adamc@649
|
189 case e of
|
adamc@649
|
190 EApp (
|
adamc@649
|
191 (EApp
|
adamc@649
|
192 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
|
adamc@649
|
193 (EFfi ("Basis", "transaction_monad"), _)), _),
|
adamc@649
|
194 (ECase (ed, pes, {disc, ...}), _)), _),
|
adamc@649
|
195 trans2) =>
|
adamc@649
|
196 let
|
adamc@649
|
197 val e' = (EFfi ("Basis", "bind"), loc)
|
adamc@649
|
198 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
|
adamc@649
|
199 val e' = (ECApp (e', t1), loc)
|
adamc@649
|
200 val e' = (ECApp (e', t2), loc)
|
adamc@649
|
201 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
|
adamc@649
|
202
|
adamc@649
|
203 val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
|
adamc@649
|
204 let
|
adamc@649
|
205 val e' = (EApp (e', e), loc)
|
adamc@649
|
206 val e' = (EApp (e',
|
adamc@649
|
207 multiLiftExpInExp (E.patBindsN p)
|
adamc@649
|
208 trans2), loc)
|
adamc@649
|
209 val (e', st) = doExp (e', st)
|
adamc@649
|
210 in
|
adamc@649
|
211 ((p, e'), st)
|
adamc@649
|
212 end) st pes
|
adamc@649
|
213 in
|
adamc@649
|
214 (ECase (ed, pes, {disc = disc,
|
adamc@649
|
215 result = (CApp ((CFfi ("Basis", "transaction"), loc), t2), loc)}),
|
adamc@649
|
216 st)
|
adamc@649
|
217 end
|
adamc@649
|
218
|
adamc@649
|
219 | EApp (
|
adamc@649
|
220 (EApp
|
adamc@649
|
221 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
|
adamc@649
|
222 (EFfi ("Basis", "transaction_monad"), _)), _),
|
adamc@649
|
223 (EServerCall (n, es, ke, t), _)), _),
|
adamc@649
|
224 trans2) =>
|
adamc@649
|
225 let
|
adamc@649
|
226 val e' = (EFfi ("Basis", "bind"), loc)
|
adamc@649
|
227 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
|
adamc@649
|
228 val e' = (ECApp (e', t), loc)
|
adamc@649
|
229 val e' = (ECApp (e', t2), loc)
|
adamc@649
|
230 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
|
adamc@649
|
231 val e' = (EApp (e', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc)
|
adamc@649
|
232 val e' = (EApp (e', E.liftExpInExp 0 trans2), loc)
|
adamc@649
|
233 val e' = (EAbs ("x", t, t2, e'), loc)
|
adamc@649
|
234 val e' = (EServerCall (n, es, e', t), loc)
|
adamc@649
|
235 val (e', st) = doExp (e', st)
|
adamc@649
|
236 in
|
adamc@649
|
237 (#1 e', st)
|
adamc@649
|
238 end
|
adamc@649
|
239
|
adamc@649
|
240 | EApp (
|
adamc@649
|
241 (EApp
|
adamc@649
|
242 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), _), _), t3), _),
|
adamc@649
|
243 (EFfi ("Basis", "transaction_monad"), _)), _),
|
adamc@649
|
244 (EApp ((EApp
|
adamc@649
|
245 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
|
adamc@649
|
246 (EFfi ("Basis", "transaction_monad"), _)), _),
|
adamc@649
|
247 trans1), _), trans2), _)), _),
|
adamc@649
|
248 trans3) =>
|
adamc@649
|
249 let
|
adamc@649
|
250 val e'' = (EFfi ("Basis", "bind"), loc)
|
adamc@649
|
251 val e'' = (ECApp (e'', (CFfi ("Basis", "transaction"), loc)), loc)
|
adamc@649
|
252 val e'' = (ECApp (e'', t2), loc)
|
adamc@649
|
253 val e'' = (ECApp (e'', t3), loc)
|
adamc@649
|
254 val e'' = (EApp (e'', (EFfi ("Basis", "transaction_monad"), loc)), loc)
|
adamc@649
|
255 val e'' = (EApp (e'', (EApp (E.liftExpInExp 0 trans2, (ERel 0, loc)), loc)), loc)
|
adamc@649
|
256 val e'' = (EApp (e'', E.liftExpInExp 0 trans3), loc)
|
adamc@649
|
257 val e'' = (EAbs ("x", t1, (CApp ((CFfi ("Basis", "transaction"), loc), t3), loc), e''), loc)
|
adamc@649
|
258
|
adamc@649
|
259 val e' = (EFfi ("Basis", "bind"), loc)
|
adamc@649
|
260 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
|
adamc@649
|
261 val e' = (ECApp (e', t1), loc)
|
adamc@649
|
262 val e' = (ECApp (e', t3), loc)
|
adamc@649
|
263 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
|
adamc@649
|
264 val e' = (EApp (e', trans1), loc)
|
adamc@649
|
265 val e' = (EApp (e', e''), loc)
|
adamc@649
|
266 val (e', st) = doExp (e', st)
|
adamc@649
|
267 in
|
adamc@649
|
268 (#1 e', st)
|
adamc@649
|
269 end
|
adamc@649
|
270
|
adamc@649
|
271 | EApp (
|
adamc@649
|
272 (EApp
|
adamc@649
|
273 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), _), _), _), _),
|
adamc@649
|
274 (EFfi ("Basis", "transaction_monad"), _)), _),
|
adamc@649
|
275 _), loc),
|
adamc@649
|
276 (EAbs (_, _, _, (EWrite _, _)), _)) => (e, st)
|
adamc@649
|
277
|
adamc@649
|
278 | EApp (
|
adamc@649
|
279 (EApp
|
adamc@649
|
280 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
|
adamc@649
|
281 (EFfi ("Basis", "transaction_monad"), _)), _),
|
adamc@649
|
282 trans1), loc),
|
adamc@649
|
283 trans2) =>
|
adamc@649
|
284 (case (serverSide (#cpsed_range st) trans1, clientSide (#cpsed_range st) trans1,
|
adamc@649
|
285 serverSide (#cpsed_range st) trans2, clientSide (#cpsed_range st) trans2) of
|
adamc@649
|
286 (true, false, _, true) => newRpc (trans1, trans2, st)
|
adamc@649
|
287 | (true, true, _, _) =>
|
adamc@649
|
288 let
|
adamc@649
|
289 val (n, args) = getApp (trans1, [])
|
adamc@649
|
290
|
adamc@649
|
291 fun makeCall n' =
|
adamc@649
|
292 let
|
adamc@649
|
293 val e = (ENamed n', loc)
|
adamc@649
|
294 val e = (EApp (e, trans2), loc)
|
adamc@649
|
295 in
|
adamc@649
|
296 #1 (foldl (fn (arg, e) => (EApp (e, arg), loc)) e args)
|
adamc@649
|
297 end
|
adamc@649
|
298 in
|
adamc@649
|
299 case IM.find (#cpsed_range st, n) of
|
adamc@649
|
300 SOME kdom =>
|
adamc@649
|
301 (case args of
|
adamc@649
|
302 [] => raise Fail "Rpcify: cps'd function lacks first argument"
|
adamc@649
|
303 | ke :: args =>
|
adamc@649
|
304 let
|
adamc@649
|
305 val ke' = (EFfi ("Basis", "bind"), loc)
|
adamc@649
|
306 val ke' = (ECApp (ke', (CFfi ("Basis", "transaction"), loc)), loc)
|
adamc@649
|
307 val ke' = (ECApp (ke', kdom), loc)
|
adamc@649
|
308 val ke' = (ECApp (ke', t2), loc)
|
adamc@649
|
309 val ke' = (EApp (ke', (EFfi ("Basis", "transaction_monad"), loc)), loc)
|
adamc@649
|
310 val ke' = (EApp (ke', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc)
|
adamc@649
|
311 val ke' = (EApp (ke', E.liftExpInExp 0 trans2), loc)
|
adamc@649
|
312 val ke' = (EAbs ("x", kdom,
|
adamc@649
|
313 (CApp ((CFfi ("Basis", "transaction"), loc), t2), loc),
|
adamc@649
|
314 ke'), loc)
|
adamc@649
|
315
|
adamc@649
|
316 val e' = (ENamed n, loc)
|
adamc@649
|
317 val e' = (EApp (e', ke'), loc)
|
adamc@649
|
318 val e' = foldl (fn (arg, e') => (EApp (e', arg), loc)) e' args
|
adamc@649
|
319 val (e', st) = doExp (e', st)
|
adamc@649
|
320 in
|
adamc@649
|
321 (#1 e', st)
|
adamc@649
|
322 end)
|
adamc@649
|
323 | NONE =>
|
adamc@649
|
324 case IM.find (#cpsed st, n) of
|
adamc@649
|
325 SOME n' => (makeCall n', st)
|
adamc@649
|
326 | NONE =>
|
adamc@642
|
327 let
|
adamc@649
|
328 val (name, fargs, ran, e) =
|
adamc@649
|
329 case IM.find (tfuncs, n) of
|
adamc@649
|
330 NONE => (Print.prefaces "BAD" [("e",
|
adamc@649
|
331 CorePrint.p_exp CoreEnv.empty (e, loc))];
|
adamc@649
|
332 raise Fail "Rpcify: Undetected transaction function [2]")
|
adamc@649
|
333 | SOME x => x
|
adamc@642
|
334
|
adamc@649
|
335 val n' = #maxName st
|
adamc@649
|
336
|
adamc@649
|
337 val st = {cpsed = IM.insert (#cpsed st, n, n'),
|
adamc@649
|
338 cpsed_range = IM.insert (#cpsed_range st, n', ran),
|
adamc@649
|
339 cps_decls = #cps_decls st,
|
adamc@649
|
340 exported = #exported st,
|
adamc@649
|
341 export_decls = #export_decls st,
|
adamc@649
|
342 maxName = n' + 1}
|
adamc@649
|
343
|
adamc@649
|
344 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
|
adamc@649
|
345 val body = (EFfi ("Basis", "bind"), loc)
|
adamc@649
|
346 val body = (ECApp (body, (CFfi ("Basis", "transaction"), loc)), loc)
|
adamc@649
|
347 val body = (ECApp (body, t1), loc)
|
adamc@649
|
348 val body = (ECApp (body, unit), loc)
|
adamc@649
|
349 val body = (EApp (body, (EFfi ("Basis", "transaction_monad"), loc)), loc)
|
adamc@649
|
350 val body = (EApp (body, e), loc)
|
adamc@649
|
351 val body = (EApp (body, (ERel (length args), loc)), loc)
|
adamc@649
|
352 val bt = (CApp ((CFfi ("Basis", "transaction"), loc), unit), loc)
|
adamc@649
|
353 val (body, bt) = foldr (fn ((x, t), (body, bt)) =>
|
adamc@649
|
354 ((EAbs (x, t, bt, body), loc),
|
adamc@649
|
355 (TFun (t, bt), loc)))
|
adamc@649
|
356 (body, bt) fargs
|
adamc@649
|
357 val kt = (TFun (ran, (CApp ((CFfi ("Basis", "transaction"), loc),
|
adamc@649
|
358 unit),
|
adamc@649
|
359 loc)), loc)
|
adamc@649
|
360 val body = (EAbs ("k", kt, bt, body), loc)
|
adamc@649
|
361 val bt = (TFun (kt, bt), loc)
|
adamc@649
|
362
|
adamc@649
|
363 val (body, st) = doExp (body, st)
|
adamc@649
|
364
|
adamc@649
|
365 val vi = (name ^ "_cps",
|
adamc@649
|
366 n',
|
adamc@649
|
367 bt,
|
adamc@649
|
368 body,
|
adamc@649
|
369 "")
|
adamc@649
|
370
|
adamc@649
|
371 val st = {cpsed = #cpsed st,
|
adamc@649
|
372 cpsed_range = #cpsed_range st,
|
adamc@649
|
373 cps_decls = vi :: #cps_decls st,
|
adamc@649
|
374 exported = #exported st,
|
adamc@649
|
375 export_decls = #export_decls st,
|
adamc@649
|
376 maxName = #maxName st}
|
adamc@642
|
377 in
|
adamc@649
|
378 (makeCall n', st)
|
adamc@649
|
379 end
|
adamc@649
|
380 end
|
adamc@649
|
381 | _ => (e, st))
|
adamc@642
|
382
|
adamc@649
|
383 | ERecord xes =>
|
adamc@649
|
384 let
|
adamc@649
|
385 val loc = case xes of
|
adamc@649
|
386 [] => ErrorMsg.dummySpan
|
adamc@649
|
387 | (_, (_, loc), _) :: _ => loc
|
adamc@642
|
388
|
adamc@649
|
389 fun candidate (x, e) =
|
adamc@649
|
390 String.isPrefix "On" x
|
adamc@649
|
391 andalso serverSide (#cpsed_range st) e
|
adamc@649
|
392 andalso not (clientSide (#cpsed_range st) e)
|
adamc@649
|
393 in
|
adamc@649
|
394 if List.exists (fn ((CName x, _), e, _) => candidate (x, e)
|
adamc@649
|
395 | _ => false) xes then
|
adamc@649
|
396 let
|
adamc@649
|
397 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
|
adamc@642
|
398
|
adamc@649
|
399 val k = (EFfi ("Basis", "return"), loc)
|
adamc@649
|
400 val k = (ECApp (k, (CFfi ("Basis", "transaction"), loc)), loc)
|
adamc@649
|
401 val k = (ECApp (k, unit), loc)
|
adamc@649
|
402 val k = (EApp (k, (EFfi ("Basis", "transaction_monad"), loc)), loc)
|
adamc@649
|
403 val k = (EApp (k, (ERecord [], loc)), loc)
|
adamc@649
|
404 val k = (EAbs ("_", unit, unit, k), loc)
|
adamc@642
|
405
|
adamc@649
|
406 val (xes, st) = ListUtil.foldlMap
|
adamc@649
|
407 (fn (y as (nm as (CName x, _), e, t), st) =>
|
adamc@649
|
408 if candidate (x, e) then
|
adamc@649
|
409 let
|
adamc@649
|
410 val (n, args) = getApp (e, [])
|
adamc@642
|
411
|
adamc@649
|
412 val (e, st) = newRpc (e, k, st)
|
adamc@649
|
413 in
|
adamc@649
|
414 ((nm, (e, loc), t), st)
|
adamc@649
|
415 end
|
adamc@649
|
416 else
|
adamc@649
|
417 (y, st)
|
adamc@649
|
418 | y => y)
|
adamc@649
|
419 st xes
|
adamc@649
|
420 in
|
adamc@649
|
421 (ERecord xes, st)
|
adamc@649
|
422 end
|
adamc@649
|
423 else
|
adamc@649
|
424 (e, st)
|
adamc@649
|
425 end
|
adamc@642
|
426
|
adamc@649
|
427 | _ => (e, st)
|
adamc@649
|
428 end
|
adamc@607
|
429
|
adamc@642
|
430 and doExp (e, st) = U.Exp.foldMap {kind = fn x => x,
|
adamc@642
|
431 con = fn x => x,
|
adamc@642
|
432 exp = exp} st (ReduceLocal.reduceExp e)
|
adamc@642
|
433
|
adamc@607
|
434 fun decl (d, st : state) =
|
adamc@607
|
435 let
|
adamc@607
|
436 val (d, st) = U.Decl.foldMap {kind = fn x => x,
|
adamc@607
|
437 con = fn x => x,
|
adamc@607
|
438 exp = exp,
|
adamc@607
|
439 decl = fn x => x}
|
adamc@607
|
440 st d
|
adamc@607
|
441 in
|
adamc@608
|
442 (List.revAppend (case #cps_decls st of
|
adamc@608
|
443 [] => [d]
|
adamc@608
|
444 | ds =>
|
adamc@608
|
445 case d of
|
adamc@608
|
446 (DValRec vis, loc) => [(DValRec (ds @ vis), loc)]
|
adamc@608
|
447 | (_, loc) => [d, (DValRec ds, loc)],
|
adamc@608
|
448 #export_decls st),
|
adamc@608
|
449 {cpsed = #cpsed st,
|
adamc@642
|
450 cpsed_range = #cpsed_range st,
|
adamc@608
|
451 cps_decls = [],
|
adamc@608
|
452
|
adamc@608
|
453 exported = #exported st,
|
adamc@642
|
454 export_decls = [],
|
adamc@642
|
455
|
adamc@642
|
456 maxName = #maxName st})
|
adamc@607
|
457 end
|
adamc@607
|
458
|
adamc@607
|
459 val (file, _) = ListUtil.foldlMapConcat decl
|
adamc@608
|
460 {cpsed = IM.empty,
|
adamc@642
|
461 cpsed_range = IM.empty,
|
adamc@608
|
462 cps_decls = [],
|
adamc@608
|
463
|
adamc@608
|
464 exported = IS.empty,
|
adamc@642
|
465 export_decls = [],
|
adamc@642
|
466
|
adamc@642
|
467 maxName = U.File.maxName file + 1}
|
adamc@607
|
468 file
|
adamc@607
|
469 in
|
adamc@607
|
470 file
|
adamc@607
|
471 end
|
adamc@607
|
472
|
adamc@607
|
473 end
|