X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fspecialise%2FRules.lhs;h=4f62115f9c3d6b63ba071104a4f951d7ef5a8775;hp=c7edd8f31534eff64634e53d08d32f29b7f8c065;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=969baa167e4afa382b2558a3648d57862c4401eb

diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index c7edd8f..4f62115 100644
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -25,6 +25,7 @@ import CoreUnfold	( isCheapUnfolding, unfoldingTemplate )
 import CoreUtils	( tcEqExprX )
 import PprCore		( pprRules )
 import Type		( TvSubstEnv )
+import Coercion         ( coercionKind )
 import TcType		( tcSplitTyConApp_maybe )
 import CoreTidy		( tidyRules )
 import Id		( Id, idUnfolding, isLocalId, isGlobalId, idName,
@@ -47,7 +48,7 @@ import FastString
 import Maybes		( isJust, orElse )
 import OrdList
 import Bag
-import Util		( singleton, mapAccumL )
+import Util		( singleton )
 import List		( isPrefixOf )
 \end{code}
 
@@ -429,6 +430,38 @@ match menv subst e1 (Var v2)
 	-- Notice that we look up v2 in the in-scope set
 	-- See Note [Lookup in-scope]
 
+-- Matching a let-expression.  Consider
+--	RULE forall x.  f (g x) = <rhs>
+-- and target expression
+--	f (let { w=R } in g E))
+-- Then we'd like the rule to match, to generate
+--	let { w=R } in (\x. <rhs>) E
+-- In effect, we want to float the let-binding outward, to enable
+-- the match to happen.  This is the WHOLE REASON for accumulating
+-- bindings in the SubstEnv
+--
+-- We can only do this if
+--	(a) Widening the scope of w does not capture any variables
+--	    We use a conservative test: w is not already in scope
+--	(b) The free variables of R are not bound by the part of the
+--	    target expression outside the let binding; e.g.
+--		f (\v. let w = v+1 in g E)
+--	    Here we obviously cannot float the let-binding for w.
+
+match menv subst@(tv_subst, id_subst, binds) e1 (Let bind e2)
+  | all freshly_bound bndrs,
+    not (any locally_bound bind_fvs)
+  = match (menv { me_env = rn_env' }) 
+	  (tv_subst, id_subst, binds `snocOL` bind)
+	  e1 e2
+  where
+    rn_env   = me_env menv
+    bndrs    = bindersOf bind
+    bind_fvs = varSetElems (bindFreeVars bind)
+    freshly_bound x = not (x `rnInScope` rn_env)
+    locally_bound x = inRnEnvR rn_env x
+    rn_env' = extendRnInScopeList rn_env bndrs
+
 match menv subst (Lit lit1) (Lit lit2)
   | lit1 == lit2
   = Just subst
@@ -444,6 +477,9 @@ match menv subst (Lam x1 e1) (Lam x2 e2)
 
 -- This rule does eta expansion
 --		(\x.M)  ~  N 	iff	M  ~  N x
+-- It's important that this is *after* the let rule,
+-- so that 	(\x.M)  ~  (let y = e in \y.N)
+-- does the let thing, and then gets the lam/lam rule above
 match menv subst (Lam x1 e1) e2
   = match menv' subst e1 (App e2 (varToCoreExpr new_x))
   where
@@ -468,43 +504,16 @@ match menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
 match menv subst (Type ty1) (Type ty2)
   = match_ty menv subst ty1 ty2
 
-match menv subst (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
+match menv subst (Cast e1 co1) (Cast e2 co2)
+  | (from1, to1) <- coercionKind co1
+  , (from2, to2) <- coercionKind co2
   = do	{ subst1 <- match_ty menv subst  to1   to2
 	; subst2 <- match_ty menv subst1 from1 from2
 	; match menv subst2 e1 e2 }
 
--- Matching a let-expression.  Consider
---	RULE forall x.  f (g x) = <rhs>
--- and target expression
---	f (let { w=R } in g E))
--- Then we'd like the rule to match, to generate
---	let { w=R } in (\x. <rhs>) E
--- In effect, we want to float the let-binding outward, to enable
--- the match to happen.  This is the WHOLE REASON for accumulating
--- bindings in the SubstEnv
---
--- We can only do this if
---	(a) Widening the scope of w does not capture any variables
---	    We use a conservative test: w is not already in scope
---	(b) The free variables of R are not bound by the part of the
---	    target expression outside the let binding; e.g.
---		f (\v. let w = v+1 in g E)
---	    Here we obviously cannot float the let-binding for w.
-
-match menv subst@(tv_subst, id_subst, binds) e1 (Let bind e2)
-  | all freshly_bound bndrs,
-    not (any locally_bound bind_fvs)
-  = match (menv { me_env = rn_env' }) 
-	  (tv_subst, id_subst, binds `snocOL` bind)
-	  e1 e2
-  where
-    rn_env   = me_env menv
-    bndrs    = bindersOf bind
-    bind_fvs = varSetElems (bindFreeVars bind)
-    freshly_bound x = not (x `rnInScope` rn_env)
-    locally_bound x = inRnEnvR rn_env x
-    rn_env' = extendRnInScopeList rn_env bndrs
-
+{-	REMOVING OLD CODE: I think that the above handling for let is 
+			   better than the stuff here, which looks 
+			   pretty suspicious to me.  SLPJ Sept 06
 -- This is an interesting rule: we simply ignore lets in the 
 -- term being matched against!  The unfolding inside it is (by assumption)
 -- already inside any occurrences of the bound variables, so we'll expand
@@ -526,7 +535,7 @@ match menv subst e1 (Let bind e2)
 	-- We must not get success with x->y!  So we record that y is
 	-- locally bound (with rnBndrR), and proceed.  The Var case
 	-- will fail when trying to bind x->y
-	--
+-}
 
 -- Everything else fails
 match menv subst e1 e2 = Nothing
@@ -684,6 +693,7 @@ ruleCheck env (Lit l) 	    = emptyBag
 ruleCheck env (Type ty)     = emptyBag
 ruleCheck env (App f a)     = ruleCheckApp env (App f a) []
 ruleCheck env (Note n e)    = ruleCheck env e
+ruleCheck env (Cast e co)   = ruleCheck env e
 ruleCheck env (Let bd e)    = ruleCheckBind env bd `unionBags` ruleCheck env e
 ruleCheck env (Lam b e)     = ruleCheck env e
 ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`