Mercurial > urweb

comparison src/rpcify.sml @ 651:bab524996fca

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Noisy demo
author Adam Chlipala <adamc@hcoop.net>
date Tue, 10 Mar 2009 17:29:03 -0400
parents fcf0bd3d1667
children b0c1a46b1f15
comparison
equal deleted inserted replaced
650:fcf0bd3d1667 651:bab524996fca
186 186
187 val e' = EServerCall (n, args, trans2, ran) 187 val e' = EServerCall (n, args, trans2, ran)
188 in 188 in
189 (e', st) 189 (e', st)
190 end 190 end
191
192 fun newCps (t1, t2, trans1, trans2, st) =
193 let
194 val loc = #2 trans1
195
196 val (n, args) = getApp (trans1, [])
197
198 fun makeCall n' =
199 let
200 val e = (ENamed n', loc)
201 val e = (EApp (e, trans2), loc)
202 in
203 #1 (foldl (fn (arg, e) => (EApp (e, arg), loc)) e args)
204 end
205 in
206 case IM.find (#cpsed_range st, n) of
207 SOME kdom =>
208 (case args of
209 [] => raise Fail "Rpcify: cps'd function lacks first argument"
210 | ke :: args =>
211 let
212 val ke' = (EFfi ("Basis", "bind"), loc)
213 val ke' = (ECApp (ke', (CFfi ("Basis", "transaction"), loc)), loc)
214 val ke' = (ECApp (ke', kdom), loc)
215 val ke' = (ECApp (ke', t2), loc)
216 val ke' = (EApp (ke', (EFfi ("Basis", "transaction_monad"), loc)), loc)
217 val ke' = (EApp (ke', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc)
218 val ke' = (EApp (ke', E.liftExpInExp 0 trans2), loc)
219 val ke' = (EAbs ("x", kdom,
220 (CApp ((CFfi ("Basis", "transaction"), loc), t2), loc),
221 ke'), loc)
222
223 val e' = (ENamed n, loc)
224 val e' = (EApp (e', ke'), loc)
225 val e' = foldl (fn (arg, e') => (EApp (e', arg), loc)) e' args
226 val (e', st) = doExp (e', st)
227 in
228 (#1 e', st)
229 end)
230 | NONE =>
231 case IM.find (#cpsed st, n) of
232 SOME n' => (makeCall n', st)
233 | NONE =>
234 let
235 val (name, fargs, ran, e) =
236 case IM.find (tfuncs, n) of
237 NONE => (Print.prefaces "BAD" [("e",
238 CorePrint.p_exp CoreEnv.empty (e, loc))];
239 raise Fail "Rpcify: Undetected transaction function [2]")
240 | SOME x => x
241
242 val n' = #maxName st
243
244 val st = {cpsed = IM.insert (#cpsed st, n, n'),
245 cpsed_range = IM.insert (#cpsed_range st, n', ran),
246 cps_decls = #cps_decls st,
247 exported = #exported st,
248 export_decls = #export_decls st,
249 maxName = n' + 1}
250
251 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
252 val body = (EFfi ("Basis", "bind"), loc)
253 val body = (ECApp (body, (CFfi ("Basis", "transaction"), loc)), loc)
254 val body = (ECApp (body, t1), loc)
255 val body = (ECApp (body, unit), loc)
256 val body = (EApp (body, (EFfi ("Basis", "transaction_monad"), loc)), loc)
257 val body = (EApp (body, e), loc)
258 val body = (EApp (body, (ERel (length args), loc)), loc)
259 val bt = (CApp ((CFfi ("Basis", "transaction"), loc), unit), loc)
260 val (body, bt) = foldr (fn ((x, t), (body, bt)) =>
261 ((EAbs (x, t, bt, body), loc),
262 (TFun (t, bt), loc)))
263 (body, bt) fargs
264 val kt = (TFun (ran, (CApp ((CFfi ("Basis", "transaction"), loc),
265 unit),
266 loc)), loc)
267 val body = (EAbs ("k", kt, bt, body), loc)
268 val bt = (TFun (kt, bt), loc)
269
270 val (body, st) = doExp (body, st)
271
272 val vi = (name ^ "_cps",
273 n',
274 bt,
275 body,
276 "")
277
278 val st = {cpsed = #cpsed st,
279 cpsed_range = #cpsed_range st,
280 cps_decls = vi :: #cps_decls st,
281 exported = #exported st,
282 export_decls = #export_decls st,
283 maxName = #maxName st}
284 in
285 (makeCall n', st)
286 end
287 end
288
289 fun dummyK loc =
290 let
291 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
292
293 val k = (EFfi ("Basis", "return"), loc)
294 val k = (ECApp (k, (CFfi ("Basis", "transaction"), loc)), loc)
295 val k = (ECApp (k, unit), loc)
296 val k = (EApp (k, (EFfi ("Basis", "transaction_monad"), loc)), loc)
297 val k = (EApp (k, (ERecord [], loc)), loc)
298 in
299 (EAbs ("_", unit, unit, k), loc)
300 end
191 in 301 in
192 case e of 302 case e of
193 EApp ( 303 EApp (
194 (EApp 304 (EApp
195 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _), 305 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
285 trans1), loc), 395 trans1), loc),
286 trans2) => 396 trans2) =>
287 (case (serverSide (#cpsed_range st) trans1, clientSide (#cpsed_range st) trans1, 397 (case (serverSide (#cpsed_range st) trans1, clientSide (#cpsed_range st) trans1,
288 serverSide (#cpsed_range st) trans2, clientSide (#cpsed_range st) trans2) of 398 serverSide (#cpsed_range st) trans2, clientSide (#cpsed_range st) trans2) of
289 (true, false, _, true) => newRpc (trans1, trans2, st) 399 (true, false, _, true) => newRpc (trans1, trans2, st)
290 | (true, true, _, _) => 400 | (_, true, true, false) =>
291 let 401 (case #1 trans2 of
292 val (n, args) = getApp (trans1, []) 402 EAbs (x, dom, ran, trans2) =>
293 403 let
294 fun makeCall n' = 404 val (trans2, st) = newRpc (trans2, dummyK loc, st)
295 let 405 val trans2 = (EAbs (x, dom, ran, (trans2, loc)), loc)
296 val e = (ENamed n', loc) 406
297 val e = (EApp (e, trans2), loc) 407 val e = (EFfi ("Basis", "bind"), loc)
298 in 408 val e = (ECApp (e, (CFfi ("Basis", "transaction"), loc)), loc)
299 #1 (foldl (fn (arg, e) => (EApp (e, arg), loc)) e args) 409 val e = (ECApp (e, t1), loc)
300 end 410 val e = (ECApp (e, t2), loc)
301 in 411 val e = (EApp (e, (EFfi ("Basis", "transaction_monad"), loc)), loc)
302 case IM.find (#cpsed_range st, n) of 412 val e = (EApp (e, trans1), loc)
303 SOME kdom => 413 val e = EApp (e, trans2)
304 (case args of 414 in
305 [] => raise Fail "Rpcify: cps'd function lacks first argument" 415 (e, st)
306 | ke :: args => 416 end
307 let 417 | _ => (e, st))
308 val ke' = (EFfi ("Basis", "bind"), loc) 418 | (true, true, _, _) => newCps (t1, t2, trans1, trans2, st)
309 val ke' = (ECApp (ke', (CFfi ("Basis", "transaction"), loc)), loc) 419
310 val ke' = (ECApp (ke', kdom), loc)
311 val ke' = (ECApp (ke', t2), loc)
312 val ke' = (EApp (ke', (EFfi ("Basis", "transaction_monad"), loc)), loc)
313 val ke' = (EApp (ke', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc)
314 val ke' = (EApp (ke', E.liftExpInExp 0 trans2), loc)
315 val ke' = (EAbs ("x", kdom,
316 (CApp ((CFfi ("Basis", "transaction"), loc), t2), loc),
317 ke'), loc)
318
319 val e' = (ENamed n, loc)
320 val e' = (EApp (e', ke'), loc)
321 val e' = foldl (fn (arg, e') => (EApp (e', arg), loc)) e' args
322 val (e', st) = doExp (e', st)
323 in
324 (#1 e', st)
325 end)
326 | NONE =>
327 case IM.find (#cpsed st, n) of
328 SOME n' => (makeCall n', st)
329 | NONE =>
330 let
331 val (name, fargs, ran, e) =
332 case IM.find (tfuncs, n) of
333 NONE => (Print.prefaces "BAD" [("e",
334 CorePrint.p_exp CoreEnv.empty (e, loc))];
335 raise Fail "Rpcify: Undetected transaction function [2]")
336 | SOME x => x
337
338 val () = Print.prefaces "Double true"
339 [("trans1", CorePrint.p_exp CoreEnv.empty trans1),
340 ("e", CorePrint.p_exp CoreEnv.empty e)]
341
342 val n' = #maxName st
343
344 val st = {cpsed = IM.insert (#cpsed st, n, n'),
345 cpsed_range = IM.insert (#cpsed_range st, n', ran),
346 cps_decls = #cps_decls st,
347 exported = #exported st,
348 export_decls = #export_decls st,
349 maxName = n' + 1}
350
351 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
352 val body = (EFfi ("Basis", "bind"), loc)
353 val body = (ECApp (body, (CFfi ("Basis", "transaction"), loc)), loc)
354 val body = (ECApp (body, t1), loc)
355 val body = (ECApp (body, unit), loc)
356 val body = (EApp (body, (EFfi ("Basis", "transaction_monad"), loc)), loc)
357 val body = (EApp (body, e), loc)
358 val body = (EApp (body, (ERel (length args), loc)), loc)
359 val bt = (CApp ((CFfi ("Basis", "transaction"), loc), unit), loc)
360 val (body, bt) = foldr (fn ((x, t), (body, bt)) =>
361 ((EAbs (x, t, bt, body), loc),
362 (TFun (t, bt), loc)))
363 (body, bt) fargs
364 val kt = (TFun (ran, (CApp ((CFfi ("Basis", "transaction"), loc),
365 unit),
366 loc)), loc)
367 val body = (EAbs ("k", kt, bt, body), loc)
368 val bt = (TFun (kt, bt), loc)
369
370 val (body, st) = doExp (body, st)
371
372 val vi = (name ^ "_cps",
373 n',
374 bt,
375 body,
376 "")
377
378 val st = {cpsed = #cpsed st,
379 cpsed_range = #cpsed_range st,
380 cps_decls = vi :: #cps_decls st,
381 exported = #exported st,
382 export_decls = #export_decls st,
383 maxName = #maxName st}
384 in
385 (makeCall n', st)
386 end
387 end
388 | _ => (e, st)) 420 | _ => (e, st))
389 421
390 | ERecord xes => 422 | ERecord xes =>
391 let 423 let
392 val loc = case xes of 424 val loc = case xes of
399 andalso not (clientSide (#cpsed_range st) e) 431 andalso not (clientSide (#cpsed_range st) e)
400 in 432 in
401 if List.exists (fn ((CName x, _), e, _) => candidate (x, e) 433 if List.exists (fn ((CName x, _), e, _) => candidate (x, e)
402 | _ => false) xes then 434 | _ => false) xes then
403 let 435 let
404 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
405
406 val k = (EFfi ("Basis", "return"), loc)
407 val k = (ECApp (k, (CFfi ("Basis", "transaction"), loc)), loc)
408 val k = (ECApp (k, unit), loc)
409 val k = (EApp (k, (EFfi ("Basis", "transaction_monad"), loc)), loc)
410 val k = (EApp (k, (ERecord [], loc)), loc)
411 val k = (EAbs ("_", unit, unit, k), loc)
412
413 val (xes, st) = ListUtil.foldlMap 436 val (xes, st) = ListUtil.foldlMap
414 (fn (y as (nm as (CName x, _), e, t), st) => 437 (fn (y as (nm as (CName x, _), e, t), st) =>
415 if candidate (x, e) then 438 if candidate (x, e) then
416 let 439 let
417 val (n, args) = getApp (e, []) 440 val (e, st) = newRpc (e, dummyK loc, st)
418
419 val (e, st) = newRpc (e, k, st)
420 in 441 in
421 ((nm, (e, loc), t), st) 442 ((nm, (e, loc), t), st)
422 end 443 end
423 else 444 else
424 (y, st) 445 (y, st)