Mercurial > urweb
comparison src/reduce.sml @ 1533:75d77fbe7c94
Distribute applications of "arrow type" ECase across branches.
author | Karn Kallio <kkallio@eka> |
---|---|
date | Fri, 12 Aug 2011 00:55:57 -0430 |
parents | 6c2e565adca6 |
children | 89d7b1c3199a |
comparison
equal
deleted
inserted
replaced
1532:7ef09e91198b | 1533:75d77fbe7c94 |
---|---|
369 Print.prefaces "Bad exp" [("e", CorePrint.p_exp CoreEnv.empty all), | 369 Print.prefaces "Bad exp" [("e", CorePrint.p_exp CoreEnv.empty all), |
370 ("env", Print.PD.string (e2s env))] | 370 ("env", Print.PD.string (e2s env))] |
371 else | 371 else |
372 ()*) | 372 ()*) |
373 | 373 |
374 fun patBinds (p, _) = | |
375 case p of | |
376 PWild => 0 | |
377 | PVar _ => 1 | |
378 | PPrim _ => 0 | |
379 | PCon (_, _, _, NONE) => 0 | |
380 | PCon (_, _, _, SOME p) => patBinds p | |
381 | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts | |
382 | |
374 val r = case e of | 383 val r = case e of |
375 EPrim _ => all | 384 EPrim _ => all |
376 | ERel n => | 385 | ERel n => |
377 let | 386 let |
378 fun find (n', env, nudge, liftK, liftC, liftE) = | 387 fun find (n', env, nudge, liftK, liftC, liftE) = |
456 ("env", Print.PD.string (e2s env')), | 465 ("env", Print.PD.string (e2s env')), |
457 ("e2", CorePrint.p_exp CoreEnv.empty e2), | 466 ("e2", CorePrint.p_exp CoreEnv.empty e2), |
458 ("r", CorePrint.p_exp CoreEnv.empty r)];*) | 467 ("r", CorePrint.p_exp CoreEnv.empty r)];*) |
459 r | 468 r |
460 end | 469 end |
470 | ECase (e, pes, cc as {disc, result = res as (TFun (_, c2), _)}) => | |
471 let | |
472 val pes' = map (fn (p, body) => | |
473 let | |
474 val env' = List.tabulate (patBinds p, fn _ => UnknownE) @ (deKnown env) | |
475 val body' = exp env' (EApp (body, multiLiftExpInExp (patBinds p) e2), #2 body) | |
476 in | |
477 (p, body') | |
478 end) pes | |
479 | |
480 val cc' = {disc = disc, result = c2} | |
481 in | |
482 (ECase (e, pes', cc'), loc) | |
483 end | |
461 | _ => (EApp (e1, e2), loc) | 484 | _ => (EApp (e1, e2), loc) |
462 end | 485 end |
463 | 486 |
464 | EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (UnknownE :: env) e), loc) | 487 | EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (UnknownE :: env) e), loc) |
465 | 488 |
477 ("env", Print.PD.string (e2s (deKnown env))), | 500 ("env", Print.PD.string (e2s (deKnown env))), |
478 ("b", CorePrint.p_exp CoreEnv.empty b), | 501 ("b", CorePrint.p_exp CoreEnv.empty b), |
479 ("c", CorePrint.p_con CoreEnv.empty c), | 502 ("c", CorePrint.p_con CoreEnv.empty c), |
480 ("r", CorePrint.p_exp CoreEnv.empty r)];*) | 503 ("r", CorePrint.p_exp CoreEnv.empty r)];*) |
481 r | 504 r |
505 end | |
506 | ECase (e, pes, cc as {disc, result = res as (TCFun (_, _, c'), _)}) => | |
507 let | |
508 val pes' = map (fn (p, body) => | |
509 let | |
510 val env' = List.tabulate (patBinds p, fn _ => UnknownE) @ (deKnown env) | |
511 | |
512 val body' = exp env' (ECApp (body, c), #2 body) | |
513 in | |
514 (p, body') | |
515 end) pes | |
516 | |
517 val c' = E.subConInCon (0, c) c' | |
518 val cc' = {disc = disc, result = c'} | |
519 in | |
520 (ECase (e, pes', cc'), loc) | |
482 end | 521 end |
483 | _ => (ECApp (e, c), loc) | 522 | _ => (ECApp (e, c), loc) |
484 end | 523 end |
485 | 524 |
486 | ECAbs (x, k, e) => (ECAbs (x, kind env k, exp (UnknownC :: env) e), loc) | 525 | ECAbs (x, k, e) => (ECAbs (x, kind env k, exp (UnknownC :: env) e), loc) |
609 | ECase (_, [((PRecord [], _), e)], _) => exp env e | 648 | ECase (_, [((PRecord [], _), e)], _) => exp env e |
610 | ECase (_, [((PWild, _), e)], _) => exp env e | 649 | ECase (_, [((PWild, _), e)], _) => exp env e |
611 | 650 |
612 | ECase (e, pes, {disc, result}) => | 651 | ECase (e, pes, {disc, result}) => |
613 let | 652 let |
614 fun patBinds (p, _) = | |
615 case p of | |
616 PWild => 0 | |
617 | PVar _ => 1 | |
618 | PPrim _ => 0 | |
619 | PCon (_, _, _, NONE) => 0 | |
620 | PCon (_, _, _, SOME p) => patBinds p | |
621 | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts | |
622 | |
623 fun pat (all as (p, loc)) = | 653 fun pat (all as (p, loc)) = |
624 case p of | 654 case p of |
625 PWild => all | 655 PWild => all |
626 | PVar (x, t) => (PVar (x, con env t), loc) | 656 | PVar (x, t) => (PVar (x, con env t), loc) |
627 | PPrim _ => all | 657 | PPrim _ => all |