X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreSubst.lhs;fp=compiler%2FcoreSyn%2FCoreSubst.lhs;h=2bb2f04bd56b4e33f21c428400ca9b4011b22486;hp=18b12a6335a5b2d1b806d84218b2dfe6a7cfbc7d;hb=30c17e7096919c55218083c8fcb98e6287552058;hpb=45a61df30f95b22d4818b6e3e3622707911bde03

diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index 18b12a6..2bb2f04 100644
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -28,7 +28,7 @@ module CoreSubst (
 	cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs,
 
 	-- ** Simple expression optimiser
-	simpleOptPgm, simpleOptExpr
+        simpleOptPgm, simpleOptExpr, simpleOptExprWith
     ) where
 
 #include "HsVersions.h"
@@ -307,13 +307,12 @@ subst_expr subst expr
     go (Lit lit)       = Lit lit
     go (App fun arg)   = App (go fun) (go arg)
     go (Note note e)   = Note (go_note note) (go e)
-    go (Cast e co) 
-      | isIdentityCoercion co' = go e
-      | otherwise              = Cast (go e) co'
-      where
-        co' = optCoercion (getTvSubst subst) co
-	-- Optimise coercions as we go; this is good, for example
-	-- in the RHS of rules, which are only substituted in
+    go (Cast e co)     = Cast (go e) (optCoercion (getTvSubst subst) co)
+       -- Do not optimise even identity coercions
+       -- Reason: substitution applies to the LHS of RULES, and
+       --         if you "optimise" an identity coercion, you may
+       --         lose a binder. We optimise the LHS of rules at
+       --         construction time
 
     go (Lam bndr body) = Lam bndr' (subst_expr subst' body)
 		       where
@@ -633,7 +632,9 @@ substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
                       	then subst_ru_fn fn_name 
                       	else fn_name,
 	   ru_args  = map (substExpr (text "subst-rule" <+> ppr fn_name) subst') args,
-	   ru_rhs   = substExpr (text "subst-rule" <+> ppr fn_name) subst' rhs }
+           ru_rhs   = simpleOptExprWith subst' rhs }
+           -- Do simple optimisation on RHS, in case substitution lets
+           -- you improve it.  The real simplifier never gets to look at it.
   where
     (subst', bndrs') = substBndrs subst bndrs
 
@@ -678,7 +679,7 @@ simpleOptExpr :: CoreExpr -> CoreExpr
 
 simpleOptExpr expr
   = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)
-    simple_opt_expr init_subst (occurAnalyseExpr expr)
+    simpleOptExprWith init_subst expr
   where
     init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
 	-- It's potentially important to make a proper in-scope set
@@ -691,6 +692,9 @@ simpleOptExpr expr
 	-- It's a bit painful to call exprFreeVars, because it makes
 	-- three passes instead of two (occ-anal, and go)
 
+simpleOptExprWith :: Subst -> InExpr -> OutExpr
+simpleOptExprWith subst expr = simple_opt_expr subst (occurAnalyseExpr expr)
+
 ----------------------
 simpleOptPgm :: DynFlags -> [CoreBind] -> [CoreRule] -> IO ([CoreBind], [CoreRule])
 simpleOptPgm dflags binds rules