Mercurial > urweb
changeset 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 | 7ef09e91198b |
| children | 89d7b1c3199a |
| files | src/reduce.sml |
| diffstat | 1 files changed, 39 insertions(+), 9 deletions(-) [+] |
line wrap: on
line diff
--- a/src/reduce.sml Wed Aug 10 18:39:27 2011 -0400 +++ b/src/reduce.sml Fri Aug 12 00:55:57 2011 -0430 @@ -371,6 +371,15 @@ else ()*) + fun patBinds (p, _) = + case p of + PWild => 0 + | PVar _ => 1 + | PPrim _ => 0 + | PCon (_, _, _, NONE) => 0 + | PCon (_, _, _, SOME p) => patBinds p + | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts + val r = case e of EPrim _ => all | ERel n => @@ -458,6 +467,20 @@ ("r", CorePrint.p_exp CoreEnv.empty r)];*) r end + | ECase (e, pes, cc as {disc, result = res as (TFun (_, c2), _)}) => + let + val pes' = map (fn (p, body) => + let + val env' = List.tabulate (patBinds p, fn _ => UnknownE) @ (deKnown env) + val body' = exp env' (EApp (body, multiLiftExpInExp (patBinds p) e2), #2 body) + in + (p, body') + end) pes + + val cc' = {disc = disc, result = c2} + in + (ECase (e, pes', cc'), loc) + end | _ => (EApp (e1, e2), loc) end @@ -480,6 +503,22 @@ ("r", CorePrint.p_exp CoreEnv.empty r)];*) r end + | ECase (e, pes, cc as {disc, result = res as (TCFun (_, _, c'), _)}) => + let + val pes' = map (fn (p, body) => + let + val env' = List.tabulate (patBinds p, fn _ => UnknownE) @ (deKnown env) + + val body' = exp env' (ECApp (body, c), #2 body) + in + (p, body') + end) pes + + val c' = E.subConInCon (0, c) c' + val cc' = {disc = disc, result = c'} + in + (ECase (e, pes', cc'), loc) + end | _ => (ECApp (e, c), loc) end @@ -611,15 +650,6 @@ | ECase (e, pes, {disc, result}) => let - fun patBinds (p, _) = - case p of - PWild => 0 - | PVar _ => 1 - | PPrim _ => 0 - | PCon (_, _, _, NONE) => 0 - | PCon (_, _, _, SOME p) => patBinds p - | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts - fun pat (all as (p, loc)) = case p of PWild => all