Match let before lambda in rule-matching (see comment with Lam case of Rules.match)

diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 35a0bdd..4f62115 100644 (file)
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -48,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}
 
@@ -430,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
@@ -445,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
@@ -476,38 +511,9 @@ match menv subst (Cast e1 co1) (Cast e2 co2)
        ; 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
@@ -529,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
@@ -687,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`