summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Karn Kallio <kkallio@eka>2011-08-11 23:55:57 -0530
committerGravatar Karn Kallio <kkallio@eka>2011-08-11 23:55:57 -0530
commiteb12686e6aa16540ee8dbe97b5cb9648e387039f (patch)
treea1661a3935d2eac4f9294c9d2b0c34c0cac82dc3 /src
parent67ac8bb3984807fc3facefa553979d5a1ae8b595 (diff)
Distribute applications of "arrow type" ECase across branches.
Diffstat (limited to 'src')
-rw-r--r--src/reduce.sml48
1 files changed, 39 insertions, 9 deletions
diff --git a/src/reduce.sml b/src/reduce.sml
index c18c698b..77863bdb 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -371,6 +371,15 @@ fun kindConAndExp (namedC, namedE) =
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 @@ fun kindConAndExp (namedC, namedE) =
("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 @@ fun kindConAndExp (namedC, namedE) =
("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 @@ fun kindConAndExp (namedC, namedE) =
| 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