Mercurial > urweb

comparison src/reduce.sml @ 1533:75d77fbe7c94

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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