X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Normalize.hs;h=747a95b0c6eccd898bfbd12e0bec80f33a0910ae;hb=019e55a763768d778d0e62b4dc5e49f3c7e06a0f;hp=9aedb4b856a17f8292241262df1f9622527efb9a;hpb=ef589dec9b04aa3d0a30a2b0787c50d07c320563;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Normalize.hs b/Normalize.hs
index 9aedb4b..747a95b 100644
--- a/Normalize.hs
+++ b/Normalize.hs
@@ -49,7 +49,7 @@ eta expr | is_fun expr && not (is_lam expr) = do
   change (Lam id (App expr (Var id)))
 -- Leave all other expressions unchanged
 eta e = return e
-etatop = notapplied ("eta", eta)
+etatop = notappargs ("eta", eta)
 
 --------------------------------
 -- β-reduction
@@ -69,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
 --------------------------------
@@ -407,7 +421,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 ::