X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Normalize.hs;h=9ee919ab524be8a211b99fe4b22bd7a03478079a;hb=69f55a9c6716f385e22378ce8be378e08b02377d;hp=cceefc0cf7baf76c4135da6ef12cc7f9c5922988;hpb=757befa0b3e9765ad3eca2990df8a790e187326c;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Normalize.hs b/Normalize.hs
index cceefc0..9ee919a 100644
--- a/Normalize.hs
+++ b/Normalize.hs
@@ -43,7 +43,6 @@ import Pretty
 -- η abstraction
 --------------------------------
 eta, etatop :: Transform
-eta expr | is_fun expr && not (is_lam expr) = do
 eta expr | is_fun expr && not (is_lam expr) = do
   let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr
   id <- mkInternalVar "param" arg_ty
@@ -70,6 +69,20 @@ beta expr = return expr
 -- Perform this transform everywhere
 betatop = everywhere ("beta", beta)
 
+--------------------------------
+-- Cast propagation
+--------------------------------
+-- Try to move casts as much downward as possible.
+castprop, castproptop :: Transform
+castprop (Cast (Let binds expr) ty) = change $ Let binds (Cast expr ty)
+castprop expr@(Cast (Case scrut b _ alts) ty) = change (Case scrut b ty alts')
+  where
+    alts' = map (\(con, bndrs, expr) -> (con, bndrs, (Cast expr ty))) alts
+-- Leave all other expressions unchanged
+castprop expr = return expr
+-- Perform this transform everywhere
+castproptop = everywhere ("castprop", castprop)
+
 --------------------------------
 -- let recursification
 --------------------------------
@@ -127,7 +140,7 @@ letflattop = everywhere ("letflat", letflat)
 --------------------------------
 -- Remove a = b bindings from let expressions everywhere
 letremovetop :: Transform
-letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) -> True; otherwise -> False))
+letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) | not $ Id.isDataConWorkId v -> True; otherwise -> False))
 
 --------------------------------
 -- Function inlining
@@ -275,8 +288,9 @@ caseremovetop = everywhere ("caseremove", caseremove)
 --------------------------------
 -- Make sure that all arguments in an application are simple variables.
 appsimpl, appsimpltop :: Transform
--- Don't simplify arguments that are already simple
-appsimpl expr@(App f (Var _)) = return expr
+-- Don't simplify arguments that are already simple. Do simplify datacons,
+-- however, since we can't portmap literals.
+appsimpl expr@(App f (Var v)) | not $ Id.isDataConWorkId v = return expr
 -- Simplify all non-applicable (to prevent loops with inlinefun) arguments,
 -- except for type arguments (since a let can't bind type vars, only a lambda
 -- can). Do this by introducing a new Let that binds the argument and passing
@@ -408,7 +422,7 @@ funproptop = everywhere ("funprop", funprop)
 
 
 -- What transforms to run?
-transforms = [typeproptop, funproptop, etatop, betatop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop]
+transforms = [typeproptop, funproptop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop]
 
 -- Turns the given bind into VHDL
 normalizeModule ::