summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2010-03-04 16:59:13 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2010-03-04 16:59:13 -0500
commitefe9d5a1b86ec354e6503222b309caf930f42adb (patch)
tree1b6ecb3ca0e4e96e8c989479f7a64caca10b05e4
parentee35f5d31e88ef2f1427c8aa9d9b059959ca4c12 (diff)
Dead code elimination in Reduce code
-rw-r--r--src/reduce.sml125
1 files changed, 14 insertions, 111 deletions
diff --git a/src/reduce.sml b/src/reduce.sml
index eadc8273..150e0bad 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -42,6 +42,17 @@ fun multiLiftExpInExp n e =
else
multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e)
+val count = CoreUtil.Exp.foldB {kind = fn (_, _, c) => c,
+ con = fn (_, _, c) => c,
+ exp = fn (x, e, c) =>
+ case e of
+ ERel x' => if x = x' then c + 1 else c
+ | _ => c,
+ bind = fn (x, b) =>
+ case b of
+ CoreUtil.Exp.RelE _ => x+1
+ | _ => x} 0 0
+
val dangling =
CoreUtil.Exp.existsB {kind = fn _ => false,
con = fn _ => false,
@@ -407,121 +418,13 @@ fun kindConAndExp (namedC, namedE) =
let
val env' = deKnown env
- fun reassoc e =
- case #1 e of
- EApp
- ((EApp
- ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), mt),
- _), _), _), t3), _),
- me), _),
- (EApp ((EApp
- ((EApp ((ECApp ((ECApp ((ECApp (
- (EFfi ("Basis", "bind"), _), _), _),
- t1), _), t2), _),
- _), _),
- trans1), _), (EAbs (_, _, _, trans2), _)), _)), _),
- trans3) =>
- let
- val e'' = (EFfi ("Basis", "bind"), loc)
- val e'' = (ECApp (e'', mt), loc)
- val e'' = (ECApp (e'', t2), loc)
- val e'' = (ECApp (e'', t3), loc)
- val e'' = (EApp (e'', me), loc)
- val e'' = (EApp (e'', trans2), loc)
- val e'' = (EApp (e'', E.liftExpInExp 0 trans3), loc)
- val e'' = reassoc e''
- val e'' = (EAbs ("xb", t1, (CApp (mt, t3), loc), e''), loc)
-
- val e' = (EFfi ("Basis", "bind"), loc)
- val e' = (ECApp (e', mt), loc)
- val e' = (ECApp (e', t1), loc)
- val e' = (ECApp (e', t3), loc)
- val e' = (EApp (e', me), loc)
- val e' = (EApp (e', trans1), loc)
- val e' = (EApp (e', e''), loc)
- in
- e'
- end
-
- | EApp
- ((EApp
- ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), mt),
- _), _), _), t3), _),
- me), _),
- (EApp ((EApp
- ((EApp ((ECApp ((ECApp ((ECApp (
- (EFfi ("Basis", "bind"), _), _), _),
- t1), _), t2), _),
- _), _),
- trans1), _), trans2), _)), _),
- trans3) =>
- let
- val e'' = (EFfi ("Basis", "bind"), loc)
- val e'' = (ECApp (e'', mt), loc)
- val e'' = (ECApp (e'', t2), loc)
- val e'' = (ECApp (e'', t3), loc)
- val e'' = (EApp (e'', me), loc)
- val () = print "In2\n"
- val e'' = (EApp (e'', exp (UnknownE :: env')
- (EApp (E.liftExpInExp 0 trans2, (ERel 0, loc)),
- loc)),
- loc)
- val () = print "Out2\n"
- val e'' = (EApp (e'', E.liftExpInExp 0 trans3), loc)
- val e'' = reassoc e''
- val e'' = (EAbs ("xb", t1, (CApp (mt, t3), loc), e''), loc)
-
- val e' = (EFfi ("Basis", "bind"), loc)
- val e' = (ECApp (e', mt), loc)
- val e' = (ECApp (e', t1), loc)
- val e' = (ECApp (e', t3), loc)
- val e' = (EApp (e', me), loc)
- val e' = (EApp (e', trans1), loc)
- val e' = (EApp (e', e''), loc)
- in
- e'
- end
-
- | EApp
- ((EApp
- ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _),
- t1),
- _), t2), _),
- (EFfi ("Basis", "transaction_monad"), _)), _),
- (ECase (e, pes, {disc, ...}), _)), _), trans) =>
- let
- val e' = (EFfi ("Basis", "bind"), loc)
- val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
- val e' = (ECApp (e', t1), loc)
- val e' = (ECApp (e', t2), loc)
- val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
-
- fun doCase (p, e) =
- let
- val e' = (EApp (e', e), loc)
- val e' = (EApp (e',
- multiLiftExpInExp (E.patBindsN p)
- trans), loc)
- in
- (p, reassoc e')
- end
- in
- (ECase (e, map doCase pes,
- {disc = disc,
- result = (CApp ((CFfi ("Basis", "transaction"), loc),
- t2), loc)}), loc)
- end
-
- | _ => e
-
val e1 = exp env e1
val e2 = exp env e2
- val e12 = (*reassoc*) (EApp (e1, e2), loc)
in
- case #1 e12 of
- EApp ((EAbs (_, _, _, b), _), e2) =>
+ case #1 e1 of
+ EAbs (_, _, _, b) =>
exp (KnownE e2 :: env') b
- | _ => e12
+ | _ => (EApp (e1, e2), loc)
end
| EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (UnknownE :: env) e), loc)