Mercurial > urweb

comparison src/reduce.sml @ 1020:dfe34fad749d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
RPC uses VM support for call/cc
author Adam Chlipala <adamc@hcoop.net>
date Sun, 25 Oct 2009 14:07:10 -0400
parents 68ba074e260f
children b2311dfb3158
comparison
equal deleted inserted replaced
1019:68ba074e260f 1020:dfe34fad749d
407 407
408 fun reassoc e = 408 fun reassoc e =
409 case #1 e of 409 case #1 e of
410 EApp 410 EApp
411 ((EApp 411 ((EApp
412 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _),
413 t1),
414 _), t2), _),
415 (EFfi ("Basis", "transaction_monad"), _)), _),
416 (EServerCall (n, es, (EAbs (_, _, _, ke), _), dom, ran), _)), _),
417 trans3) =>
418 let
419 val e' = (EFfi ("Basis", "bind"), loc)
420 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
421 val e' = (ECApp (e', dom), loc)
422 val e' = (ECApp (e', t2), loc)
423 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
424 val e' = (EApp (e', ke), loc)
425 val e' = (EApp (e', E.liftExpInExp 0 trans3), loc)
426 val e' = reassoc e'
427 val e' = (EAbs ("x", dom, t2, e'), loc)
428 val e' = (EServerCall (n, es, e', dom, t2), loc)
429 in
430 e'
431 end
432
433 | EApp
434 ((EApp
435 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _),
436 t1),
437 _), t2), _),
438 (EFfi ("Basis", "transaction_monad"), _)), _),
439 (EServerCall (n, es, ke, dom, ran), _)), _),
440 trans3) =>
441 let
442 val e' = (EFfi ("Basis", "bind"), loc)
443 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
444 val e' = (ECApp (e', dom), loc)
445 val e' = (ECApp (e', t2), loc)
446 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
447 val e' = (EApp (e', exp (UnknownE :: env')
448 (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)),
449 loc)
450 val e' = (EApp (e', E.liftExpInExp 0 trans3), loc)
451 val e' = reassoc e'
452 val e' = (EAbs ("x", dom, t2, e'), loc)
453 val e' = (EServerCall (n, es, e', dom, t2), loc)
454 in
455 e'
456 end
457
458 | EApp
459 ((EApp
460 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _),
461 t1),
462 _), t2), _),
463 (EFfi ("Basis", "transaction_monad"), _)), _),
464 (ETailCall (n, es, (EAbs (_, _, _, ke), _), dom, ran), _)), _),
465 trans3) =>
466 let
467 val e' = (EFfi ("Basis", "bind"), loc)
468 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
469 val e' = (ECApp (e', dom), loc)
470 val e' = (ECApp (e', t2), loc)
471 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
472 val e' = (EApp (e', ke), loc)
473 val e' = (EApp (e', E.liftExpInExp 0 trans3), loc)
474 val e' = reassoc e'
475 val e' = (EAbs ("x", dom, t2, e'), loc)
476 val e' = (ETailCall (n, es, e', dom, t2), loc)
477 in
478 e'
479 end
480
481 | EApp
482 ((EApp
483 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _),
484 t1),
485 _), t2), _),
486 (EFfi ("Basis", "transaction_monad"), _)), _),
487 (ETailCall (n, es, ke, dom, ran), _)), _),
488 trans3) =>
489 let
490 val e' = (EFfi ("Basis", "bind"), loc)
491 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
492 val e' = (ECApp (e', dom), loc)
493 val e' = (ECApp (e', t2), loc)
494 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
495 val e' = (EApp (e', exp (UnknownE :: env')
496 (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)),
497 loc)
498 val e' = (EApp (e', E.liftExpInExp 0 trans3), loc)
499 val e' = reassoc e'
500 val e' = (EAbs ("x", dom, t2, e'), loc)
501 val e' = (ETailCall (n, es, e', dom, t2), loc)
502 in
503 e'
504 end
505
506 | EApp
507 ((EApp
508 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), mt), 412 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), mt),
509 _), _), _), t3), _), 413 _), _), _), t3), _),
510 me), _), 414 me), _),
511 (EApp ((EApp 415 (EApp ((EApp
512 ((EApp ((ECApp ((ECApp ((ECApp ( 416 ((EApp ((ECApp ((ECApp ((ECApp (
790 | EClosure (n, es) => (EClosure (n, map (exp env) es), loc) 694 | EClosure (n, es) => (EClosure (n, map (exp env) es), loc)
791 695
792 | ELet (x, t, e1, e2) => 696 | ELet (x, t, e1, e2) =>
793 (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc) 697 (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc)
794 698
795 | EServerCall (n, es, e, t1, t2) => (EServerCall (n, map (exp env) es, exp env e, 699 | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, con env t), loc)
796 con env t1, con env t2), loc)
797 | ETailCall (n, es, e, t1, t2) => (ETailCall (n, map (exp env) es, exp env e,
798 con env t1, con env t2), loc)
799 in 700 in
800 (*if dangling (edepth' (deKnown env)) r then 701 (*if dangling (edepth' (deKnown env)) r then
801 (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all), 702 (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
802 ("r", CorePrint.p_exp CoreEnv.empty r)]; 703 ("r", CorePrint.p_exp CoreEnv.empty r)];
803 raise Fail "!!") 704 raise Fail "!!")