Mercurial > urweb

comparison src/rpcify.sml @ 908:ed06e25c70ef

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