Give user-defined rules precedence over built-in rules

[ghc-hetmet.git] / compiler / specialise / Rules.lhs

diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 5bd22a1..8ff1edc 100644 (file)
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -24,7 +24,7 @@ module Rules (
        -- * Misc. CoreRule helpers
         rulesOfBinds, getRules, pprRulesForUser, 
         
        -- * Misc. CoreRule helpers
         rulesOfBinds, getRules, pprRulesForUser, 
         

-        lookupRule, mkRule, mkLocalRule, roughTopNames
+        lookupRule, mkRule, roughTopNames

     ) where
 
 #include "HsVersions.h"
     ) where
 
 #include "HsVersions.h"

@@ -32,9 +32,9 @@ module Rules (
 import CoreSyn         -- All of it
 import OccurAnal       ( occurAnalyseExpr )
 import CoreFVs         ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars )
 import CoreSyn         -- All of it
 import OccurAnal       ( occurAnalyseExpr )
 import CoreFVs         ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars )

-import CoreUtils       ( exprType )
+import CoreUtils       ( exprType, eqExprX )

 import PprCore         ( pprRules )
 import PprCore         ( pprRules )

-import Type            ( Type, TvSubstEnv, tcEqTypeX )
+import Type            ( Type, TvSubstEnv )

 import TcType          ( tcSplitTyConApp_maybe )
 import CoreTidy                ( tidyRules )
 import Id
 import TcType          ( tcSplitTyConApp_maybe )
 import CoreTidy                ( tidyRules )
 import Id

@@ -50,7 +50,6 @@ import StaticFlags    ( opt_PprStyle_Debug )
 import Outputable
 import FastString
 import Maybes
 import Outputable
 import FastString
 import Maybes

-import OrdList

 import Bag
 import Util
 import Data.List
 import Bag
 import Util
 import Data.List

@@ -59,15 +58,15 @@ import Data.List
 
 Note [Overall plumbing for rules]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 Note [Overall plumbing for rules]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

-
-* The ModGuts initially contains mg_rules :: [CoreRule] of rules
-  declared in this module. During the core-to-core pipeline,
-  locally-declared rules for locally-declared Ids are attached to the
-  IdInfo for that Id, so the mg_rules field of ModGuts now only
-  contains locally-declared rules for *imported* Ids.  TidyPgm restores
-  the original setup, so that the ModGuts again has *all* the
-  locally-declared rules.  See Note [Attach rules to local ids] in
-  SimplCore
+* After the desugarer:
+   - The ModGuts initially contains mg_rules :: [CoreRule] of
+     locally-declared rules for imported Ids.  
+   - Locally-declared rules for locally-declared Ids are attached to
+     the IdInfo for that Id.  See Note [Attach rules to local ids] in
+     DsBinds
+ 
+* TidyPgm strips off all the rules from local Ids and adds them to
+  mg_rules, so that the ModGuts has *all* the locally-declared rules.

 
 * The HomePackageTable contains a ModDetails for each home package
   module.  Each contains md_rules :: [CoreRule] of rules declared in
 
 * The HomePackageTable contains a ModDetails for each home package
   module.  Each contains md_rules :: [CoreRule] of rules declared in

@@ -106,7 +105,7 @@ Note [Overall plumbing for rules]
   The HomePackageTable doesn't have a single RuleBase because technically
   we should only be able to "see" rules "below" this module; so we
   generate a RuleBase for (c) by combing rules from all the modules
   The HomePackageTable doesn't have a single RuleBase because technically
   we should only be able to "see" rules "below" this module; so we
   generate a RuleBase for (c) by combing rules from all the modules

-  "below" us.  That's whye we can't just select the home-package RuleBase
+  "below" us.  That's why we can't just select the home-package RuleBase

   from HscEnv.
 
   [NB: we are inconsistent here.  We should do the same for external
   from HscEnv.
 
   [NB: we are inconsistent here.  We should do the same for external

@@ -157,22 +156,16 @@ might have a specialisation
 where pi' :: Lift Int# is the specialised version of pi.
 
 \begin{code}
 where pi' :: Lift Int# is the specialised version of pi.
 
 \begin{code}

-mkLocalRule :: RuleName -> Activation 
-           -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
--- ^ Used to make 'CoreRule' for an 'Id' defined in the module being 
--- compiled. See also 'CoreSyn.CoreRule'
-mkLocalRule = mkRule True
-
-mkRule :: Bool -> RuleName -> Activation 
+mkRule :: Bool -> Bool -> RuleName -> Activation 

        -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
 -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being 
 -- compiled. See also 'CoreSyn.CoreRule'
        -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
 -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being 
 -- compiled. See also 'CoreSyn.CoreRule'

-mkRule is_local name act fn bndrs args rhs
+mkRule is_auto is_local name act fn bndrs args rhs

   = Rule { ru_name = name, ru_fn = fn, ru_act = act,
           ru_bndrs = bndrs, ru_args = args,
           ru_rhs = occurAnalyseExpr rhs, 
           ru_rough = roughTopNames args,
   = Rule { ru_name = name, ru_fn = fn, ru_act = act,
           ru_bndrs = bndrs, ru_args = args,
           ru_rhs = occurAnalyseExpr rhs, 
           ru_rough = roughTopNames args,

-          ru_local = is_local }
+          ru_auto = is_auto, ru_local = is_local }

 
 --------------
 roughTopNames :: [CoreExpr] -> [Maybe Name]
 
 --------------
 roughTopNames :: [CoreExpr] -> [Maybe Name]

@@ -328,26 +321,10 @@ pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs)
 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

-\subsection{Matching}
+                       Matching

 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-Note [Extra args in rule matching]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we find a matching rule, we return (Just (rule, rhs)), 
-but the rule firing has only consumed as many of the input args
-as the ruleArity says.  It's up to the caller to keep track
-of any left-over args.  E.g. if you call
-       lookupRule ... f [e1, e2, e3]
-and it returns Just (r, rhs), where r has ruleArity 2
-then the real rewrite is
-       f e1 e2 e3 ==> rhs e3
-
-You might think it'd be cleaner for lookupRule to deal with the
-leftover arguments, by applying 'rhs' to them, but the main call
-in the Simplifier works better as it is.  Reason: the 'args' passed
-to lookupRule are the result of a lazy substitution
-

 \begin{code}
 -- | The main rule matching function. Attempts to apply all (active)
 -- supplied rules to this instance of an application in a given
 \begin{code}
 -- | The main rule matching function. Attempts to apply all (active)
 -- supplied rules to this instance of an application in a given

@@ -374,8 +351,11 @@ lookupRule is_active id_unf in_scope fn args rules
     go ms (r:rs) = case (matchRule is_active id_unf in_scope args rough_args r) of
                        Just e  -> go ((r,e):ms) rs
                        Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$ 
     go ms (r:rs) = case (matchRule is_active id_unf in_scope args rough_args r) of
                        Just e  -> go ((r,e):ms) rs
                        Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$ 

-                                  --   ppr [(arg_id, unfoldingTemplate unf) | Var arg_id <- args, let unf = idUnfolding arg_id, isCheapUnfolding unf] )
-                                  go ms         rs
+                                  --   ppr [ (arg_id, unfoldingTemplate unf) 
+                                   --       | Var arg_id <- args
+                                   --       , let unf = idUnfolding arg_id
+                                   --       , isCheapUnfolding unf] )
+                                  go ms rs

 
 findBest :: (Id, [CoreExpr])
         -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)
 
 findBest :: (Id, [CoreExpr])
         -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)

@@ -402,8 +382,18 @@ findBest target (rule1,ans1) ((rule2,ans2):prs)
     (fn,args) = target
 
 isMoreSpecific :: CoreRule -> CoreRule -> Bool
     (fn,args) = target
 
 isMoreSpecific :: CoreRule -> CoreRule -> Bool

-isMoreSpecific (BuiltinRule {}) _ = True
-isMoreSpecific _ (BuiltinRule {}) = False
+-- This tests if one rule is more specific than another
+-- We take the view that a BuiltinRule is less specific than
+-- anything else, because we want user-define rules to "win"
+-- In particular, class ops have a built-in rule, but we
+-- any user-specific rules to win
+--   eg (Trac #4397)   
+--      truncate :: (RealFrac a, Integral b) => a -> b
+--      {-# RULES "truncate/Double->Int" truncate = double2Int #-}
+--      double2Int :: Double -> Int
+--   We want the specific RULE to beat the built-in class-op rule
+isMoreSpecific (BuiltinRule {}) _                = False
+isMoreSpecific (Rule {})        (BuiltinRule {}) = True

 isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 })
               (Rule { ru_bndrs = bndrs2, ru_args = args2 })
   = isJust (matchN id_unfolding_fun in_scope bndrs2 args2 args1)
 isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 })
               (Rule { ru_bndrs = bndrs2, ru_args = args2 })
   = isJust (matchN id_unfolding_fun in_scope bndrs2 args2 args1)

@@ -415,7 +405,26 @@ isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 })
 
 noBlackList :: Activation -> Bool
 noBlackList _ = False          -- Nothing is black listed
 
 noBlackList :: Activation -> Bool
 noBlackList _ = False          -- Nothing is black listed

+\end{code}
+
+Note [Extra args in rule matching]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we find a matching rule, we return (Just (rule, rhs)), 
+but the rule firing has only consumed as many of the input args
+as the ruleArity says.  It's up to the caller to keep track
+of any left-over args.  E.g. if you call
+       lookupRule ... f [e1, e2, e3]
+and it returns Just (r, rhs), where r has ruleArity 2
+then the real rewrite is
+       f e1 e2 e3 ==> rhs e3
+
+You might think it'd be cleaner for lookupRule to deal with the
+leftover arguments, by applying 'rhs' to them, but the main call
+in the Simplifier works better as it is.  Reason: the 'args' passed
+to lookupRule are the result of a lazy substitution

 
 

+\begin{code}
+------------------------------------

 matchRule :: (Activation -> Bool) -> IdUnfoldingFun
           -> InScopeSet
          -> [CoreExpr] -> [Maybe Name]
 matchRule :: (Activation -> Bool) -> IdUnfoldingFun
           -> InScopeSet
          -> [CoreExpr] -> [Maybe Name]

@@ -458,30 +467,29 @@ matchRule is_active id_unf in_scope args rough_args
   | ruleCantMatch tpl_tops rough_args = Nothing
   | otherwise
   = case matchN id_unf in_scope tpl_vars tpl_args args of
   | ruleCantMatch tpl_tops rough_args = Nothing
   | otherwise
   = case matchN id_unf in_scope tpl_vars tpl_args args of

-       Nothing                -> Nothing
-       Just (binds, tpl_vals) -> Just (mkLets binds $
-                                       rule_fn `mkApps` tpl_vals)
+       Nothing                        -> Nothing
+       Just (bind_wrapper, tpl_vals) -> Just (bind_wrapper $
+                                              rule_fn `mkApps` tpl_vals)

   where
     rule_fn = occurAnalyseExpr (mkLams tpl_vars rhs)
        -- We could do this when putting things into the rulebase, I guess
   where
     rule_fn = occurAnalyseExpr (mkLams tpl_vars rhs)
        -- We could do this when putting things into the rulebase, I guess

-\end{code}

 
 

-\begin{code}
--- For a given match template and context, find bindings to wrap around 
--- the entire result and what should be substituted for each template variable.
--- Fail if there are two few actual arguments from the target to match the template
+---------------------------------------

 matchN :: IdUnfoldingFun
         -> InScopeSet           -- ^ In-scope variables
        -> [Var]                -- ^ Match template type variables
        -> [CoreExpr]           -- ^ Match template
        -> [CoreExpr]           -- ^ Target; can have more elements than the template
 matchN :: IdUnfoldingFun
         -> InScopeSet           -- ^ In-scope variables
        -> [Var]                -- ^ Match template type variables
        -> [CoreExpr]           -- ^ Match template
        -> [CoreExpr]           -- ^ Target; can have more elements than the template

-       -> Maybe ([CoreBind],
+       -> Maybe (BindWrapper,  -- Floated bindings; see Note [Matching lets]

                  [CoreExpr])
                  [CoreExpr])

+-- For a given match template and context, find bindings to wrap around 
+-- the entire result and what should be substituted for each template variable.
+-- Fail if there are two few actual arguments from the target to match the template

 
 matchN id_unf in_scope tmpl_vars tmpl_es target_es
   = do { (tv_subst, id_subst, binds)
                <- go init_menv emptySubstEnv tmpl_es target_es
 
 matchN id_unf in_scope tmpl_vars tmpl_es target_es
   = do { (tv_subst, id_subst, binds)
                <- go init_menv emptySubstEnv tmpl_es target_es

-       ; return (fromOL binds, 
+       ; return (binds, 

                  map (lookup_tmpl tv_subst id_subst) tmpl_vars') }
   where
     (init_rn_env, tmpl_vars') = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars
                  map (lookup_tmpl tv_subst id_subst) tmpl_vars') }
   where
     (init_rn_env, tmpl_vars') = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars

@@ -496,7 +504,7 @@ matchN id_unf in_scope tmpl_vars tmpl_es target_es
 
     lookup_tmpl :: TvSubstEnv -> IdSubstEnv -> Var -> CoreExpr
     lookup_tmpl tv_subst id_subst tmpl_var'
 
     lookup_tmpl :: TvSubstEnv -> IdSubstEnv -> Var -> CoreExpr
     lookup_tmpl tv_subst id_subst tmpl_var'

-       | isTyVar tmpl_var' = case lookupVarEnv tv_subst tmpl_var' of
+       | isTyCoVar tmpl_var' = case lookupVarEnv tv_subst tmpl_var' of

                                Just ty         -> Type ty
                                Nothing         -> unbound tmpl_var'
        | otherwise         = case lookupVarEnv id_subst tmpl_var' of
                                Just ty         -> Type ty
                                Nothing         -> unbound tmpl_var'
        | otherwise         = case lookupVarEnv id_subst tmpl_var' of

@@ -535,15 +543,19 @@ necessary; the renamed ones are the tmpl_vars'
 -- * The domain of the TvSubstEnv and IdSubstEnv are the template
 --   variables passed into the match.
 --
 -- * The domain of the TvSubstEnv and IdSubstEnv are the template
 --   variables passed into the match.
 --

--- * The (OrdList CoreBind) in a SubstEnv are the bindings floated out
+-- * The BindWrapper in a SubstEnv are the bindings floated out

 --   from nested matches; see the Let case of match, below
 --
 --   from nested matches; see the Let case of match, below
 --

-type SubstEnv   = (TvSubstEnv, IdSubstEnv, OrdList CoreBind)
+type SubstEnv = (TvSubstEnv, IdSubstEnv, BindWrapper)
+                   
+type BindWrapper = CoreExpr -> CoreExpr
+  -- See Notes [Matching lets] and [Matching cases]
+  -- we represent the floated bindings as a core-to-core function
+

 type IdSubstEnv = IdEnv CoreExpr               
 
 emptySubstEnv :: SubstEnv
 type IdSubstEnv = IdEnv CoreExpr               
 
 emptySubstEnv :: SubstEnv

-emptySubstEnv = (emptyVarEnv, emptyVarEnv, nilOL)
-
+emptySubstEnv = (emptyVarEnv, emptyVarEnv, \e -> e)

 
 --     At one stage I tried to match even if there are more 
 --     template args than real args.
 
 --     At one stage I tried to match even if there are more 
 --     template args than real args.

@@ -587,8 +599,8 @@ match idu menv subst e1 (Note _ e2) = match idu menv subst e1 e2
       -- See Note [Notes in RULE matching]
 
 match id_unfolding_fun menv subst e1 (Var v2)      -- Note [Expanding variables]
       -- See Note [Notes in RULE matching]
 
 match id_unfolding_fun menv subst e1 (Var v2)      -- Note [Expanding variables]

-  | not (locallyBoundR rn_env v2) -- Note [Do not expand locally-bound variables]
-  , Just e2' <- expandUnfolding (id_unfolding_fun v2')
+  | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables]
+  , Just e2' <- expandUnfolding_maybe (id_unfolding_fun v2')

   = match id_unfolding_fun (menv { me_env = nukeRnEnvR rn_env }) subst e1 e2'
   where
     v2'    = lookupRnInScope rn_env v2
   = match id_unfolding_fun (menv { me_env = nukeRnEnvR rn_env }) subst e1 e2'
   where
     v2'    = lookupRnInScope rn_env v2

@@ -596,22 +608,32 @@ match id_unfolding_fun menv subst e1 (Var v2)      -- Note [Expanding variables]
        -- Notice that we look up v2 in the in-scope set
        -- See Note [Lookup in-scope]
        -- No need to apply any renaming first (hence no rnOccR)
        -- Notice that we look up v2 in the in-scope set
        -- See Note [Lookup in-scope]
        -- No need to apply any renaming first (hence no rnOccR)

-       -- becuase of the not-locallyBoundR
+       -- because of the not-inRnEnvR

 
 match idu menv (tv_subst, id_subst, binds) e1 (Let bind e2)
 
 match idu menv (tv_subst, id_subst, binds) e1 (Let bind e2)

-  | all freshly_bound bndrs    -- See Note [Matching lets]
-  , not (any (locallyBoundR rn_env) bind_fvs)
+  | okToFloat rn_env bndrs (bindFreeVars bind)         -- See Note [Matching lets]

   = match idu (menv { me_env = rn_env' }) 
   = match idu (menv { me_env = rn_env' }) 

-         (tv_subst, id_subst, binds `snocOL` bind')
-         e1 e2'
+         (tv_subst, id_subst, binds . Let bind)
+         e1 e2

   where
     rn_env   = me_env menv
   where
     rn_env   = me_env menv

-    bndrs    = bindersOf  bind
-    bind_fvs = varSetElems (bindFreeVars bind)
-    freshly_bound x = not (x `rnInScope` rn_env)
-    bind'   = bind
-    e2'     = e2
-    rn_env' = extendRnInScopeList rn_env bndrs
+    rn_env'  = extendRnInScopeList rn_env bndrs
+    bndrs    = bindersOf bind
+
+{- Disabled: see Note [Matching cases] below
+match idu menv (tv_subst, id_subst, binds) e1 
+      (Case scrut case_bndr ty [(con, alt_bndrs, rhs)])
+  | exprOkForSpeculation scrut -- See Note [Matching cases]
+  , okToFloat rn_env bndrs (exprFreeVars scrut)
+  = match idu (menv { me_env = rn_env' })
+          (tv_subst, id_subst, binds . case_wrap)
+          e1 rhs 
+  where
+    rn_env   = me_env menv
+    rn_env'  = extendRnInScopeList rn_env bndrs
+    bndrs    = case_bndr : alt_bndrs
+    case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')]
+-}

 
 match _ _ subst (Lit lit1) (Lit lit2)
   | lit1 == lit2
 
 match _ _ subst (Lit lit1) (Lit lit2)
   | lit1 == lit2

@@ -634,7 +656,7 @@ match idu menv subst (Lam x1 e1) (Lam x2 e2)
 match idu menv subst (Lam x1 e1) e2
   = match idu menv' subst e1 (App e2 (varToCoreExpr new_x))
   where
 match idu menv subst (Lam x1 e1) e2
   = match idu menv' subst e1 (App e2 (varToCoreExpr new_x))
   where

-    (rn_env', new_x) = rnBndrL (me_env menv) x1
+    (rn_env', new_x) = rnEtaL (me_env menv) x1

     menv' = menv { me_env = rn_env' }
 
 -- Eta expansion the other way
     menv' = menv { me_env = rn_env' }
 
 -- Eta expansion the other way

@@ -642,7 +664,7 @@ match idu menv subst (Lam x1 e1) e2
 match idu menv subst e1 (Lam x2 e2)
   = match idu menv' subst (App e1 (varToCoreExpr new_x)) e2
   where
 match idu menv subst e1 (Lam x2 e2)
   = match idu menv' subst (App e1 (varToCoreExpr new_x)) e2
   where

-    (rn_env', new_x) = rnBndrR (me_env menv) x2
+    (rn_env', new_x) = rnEtaR (me_env menv) x2

     menv' = menv { me_env = rn_env' }
 
 match idu menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
     menv' = menv { me_env = rn_env' }
 
 match idu menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)

@@ -664,6 +686,15 @@ match _ _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (tex
                         Nothing
 
 ------------------------------------------
                         Nothing
 
 ------------------------------------------

+okToFloat :: RnEnv2 -> [Var] -> VarSet -> Bool
+okToFloat rn_env bndrs bind_fvs
+  = all freshly_bound bndrs 
+    && foldVarSet ((&&) . not_captured) True bind_fvs
+  where
+    freshly_bound x = not (x `rnInScope` rn_env)
+    not_captured fv = not (inRnEnvR rn_env fv)
+
+------------------------------------------

 match_var :: IdUnfoldingFun
           -> MatchEnv
          -> SubstEnv
 match_var :: IdUnfoldingFun
           -> MatchEnv
          -> SubstEnv

@@ -693,7 +724,7 @@ match_var idu menv subst@(tv_subst, id_subst, binds) v1 e2
                                                -- c.f. match_ty below
                        ; return (tv_subst', extendVarEnv id_subst v1' e2, binds) }
 
                                                -- c.f. match_ty below
                        ; return (tv_subst', extendVarEnv id_subst v1' e2, binds) }
 

-       Just e1' | eqExpr idu (nukeRnEnvL rn_env) e1' e2 
+       Just e1' | eqExprX idu (nukeRnEnvL rn_env) e1' e2 

                 -> Just subst
 
                 | otherwise
                 -> Just subst
 
                 | otherwise

@@ -732,21 +763,19 @@ match_alts idu menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
 
 match_alts _ _ _ _ _
   = Nothing
 
 match_alts _ _ _ _ _
   = Nothing

-\end{code}
-
-Matching Core types: use the matcher in TcType.
-Notice that we treat newtypes as opaque.  For example, suppose 
-we have a specialised version of a function at a newtype, say 
-       newtype T = MkT Int
-We only want to replace (f T) with f', not (f Int).

 
 

-\begin{code}

 ------------------------------------------
 match_ty :: MatchEnv
         -> SubstEnv
         -> Type                -- Template
         -> Type                -- Target
         -> Maybe SubstEnv
 ------------------------------------------
 match_ty :: MatchEnv
         -> SubstEnv
         -> Type                -- Template
         -> Type                -- Target
         -> Maybe SubstEnv

+-- Matching Core types: use the matcher in TcType.
+-- Notice that we treat newtypes as opaque.  For example, suppose 
+-- we have a specialised version of a function at a newtype, say 
+--     newtype T = MkT Int
+-- We only want to replace (f T) with f', not (f Int).
+

 match_ty menv (tv_subst, id_subst, binds) ty1 ty2
   = do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2
        ; return (tv_subst', id_subst, binds) }
 match_ty menv (tv_subst, id_subst, binds) ty1 ty2
   = do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2
        ; return (tv_subst', id_subst, binds) }

@@ -799,13 +828,13 @@ the match to happen.  This is the WHOLE REASON for accumulating
 bindings in the SubstEnv
 
 We can only do this if
 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
-           If not, we clone the binders, and substitute
-       (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.
+  (a) Widening the scope of w does not capture any variables
+      We use a conservative test: w is not already in scope
+      If not, we clone the binders, and substitute
+  (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.

 
 You may think rule (a) would never apply, because rule matching is
 mostly invoked from the simplifier, when we have just run substExpr 
 
 You may think rule (a) would never apply, because rule matching is
 mostly invoked from the simplifier, when we have just run substExpr 

@@ -831,7 +860,25 @@ Other cases to think about
        (let x=y+1 in (x,x), let x=y-1 in (x,x))
                --> let x=y+1 in let x1=y-1 in ((x,x),(x1,x1))
 
        (let x=y+1 in (x,x), let x=y-1 in (x,x))
                --> let x=y+1 in let x1=y-1 in ((x,x),(x1,x1))
 

-
+Note [Matching cases]
+~~~~~~~~~~~~~~~~~~~~~
+{- NOTE: This idea is currently disabled.  It really only works if
+         the primops involved are OkForSpeculation, and, since
+        they have side effects readIntOfAddr and touch are not.
+        Maybe we'll get back to this later .  -}
+  
+Consider
+   f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) ->
+      case touch# fp s# of { _ -> 
+      I# n# } } )
+This happened in a tight loop generated by stream fusion that 
+Roman encountered.  We'd like to treat this just like the let 
+case, because the primops concerned are ok-for-speculation.
+That is, we'd like to behave as if it had been
+   case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) ->
+   case touch# fp s# of { _ -> 
+   f (I# n# } } )
+  

 Note [Lookup in-scope]
 ~~~~~~~~~~~~~~~~~~~~~~
 Consider this example
 Note [Lookup in-scope]
 ~~~~~~~~~~~~~~~~~~~~~~
 Consider this example

@@ -867,77 +914,6 @@ at all.
 That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'
 is so important.
 
 That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'
 is so important.
 

-\begin{code}
-eqExpr :: IdUnfoldingFun -> RnEnv2 -> CoreExpr -> CoreExpr -> Bool
--- ^ A kind of shallow equality used in rule matching, so does 
--- /not/ look through newtypes or predicate types
-
-eqExpr _ env (Var v1) (Var v2)
-  | rnOccL env v1 == rnOccR env v2
-  = True
-
--- The next two rules expand non-local variables
--- C.f. Note [Expanding variables]
--- and  Note [Do not expand locally-bound variables]
-eqExpr id_unfolding_fun env (Var v1) e2
-  | not (locallyBoundL env v1)
-  , Just e1' <- expandUnfolding (id_unfolding_fun (lookupRnInScope env v1))
-  = eqExpr id_unfolding_fun (nukeRnEnvL env) e1' e2
-
-eqExpr id_unfolding_fun env e1 (Var v2)
-  | not (locallyBoundR env v2)
-  , Just e2' <- expandUnfolding (id_unfolding_fun (lookupRnInScope env v2))
-  = eqExpr id_unfolding_fun (nukeRnEnvR env) e1 e2'
-
-eqExpr _   _   (Lit lit1)    (Lit lit2)    = lit1 == lit2
-eqExpr idu env (App f1 a1)   (App f2 a2)   = eqExpr idu env f1 f2 && eqExpr idu env a1 a2
-eqExpr idu env (Lam v1 e1)   (Lam v2 e2)   = eqExpr idu (rnBndr2 env v1 v2) e1 e2
-eqExpr idu env (Note n1 e1)  (Note n2 e2)  = eq_note env n1 n2 && eqExpr idu env e1 e2
-eqExpr idu env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && eqExpr idu env e1 e2
-eqExpr _   env (Type t1)     (Type t2)     = tcEqTypeX env t1 t2
-
-eqExpr idu env (Let (NonRec v1 r1) e1)
-              (Let (NonRec v2 r2) e2) =  eqExpr idu env r1 r2 
-                                      && eqExpr idu (rnBndr2 env v1 v2) e1 e2
-eqExpr idu env (Let (Rec ps1) e1)
-              (Let (Rec ps2) e2)      =  equalLength ps1 ps2
-                                      && and (zipWith eq_rhs ps1 ps2)
-                                      && eqExpr idu env' e1 e2
-                                      where
-                                         env' = foldl2 rn_bndr2 env ps2 ps2
-                                         rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
-                                         eq_rhs       (_,r1) (_,r2) = eqExpr idu env' r1 r2
-eqExpr idu env (Case e1 v1 t1 a1)
-              (Case e2 v2 t2 a2) =  eqExpr idu env e1 e2
-                                 && tcEqTypeX env t1 t2                      
-                                 && equalLength a1 a2
-                                 && and (zipWith eq_alt a1 a2)
-                                 where
-                                   env' = rnBndr2 env v1 v2
-                                    eq_alt (c1,vs1,r1) (c2,vs2,r2) 
-                                       = c1==c2 && eqExpr idu (rnBndrs2 env' vs1  vs2) r1 r2
-eqExpr _ _ _ _ = False
-
-eq_note :: RnEnv2 -> Note -> Note -> Bool
-eq_note _ (SCC cc1)     (SCC cc2)      = cc1 == cc2
-eq_note _ (CoreNote s1) (CoreNote s2)  = s1 == s2
-eq_note _ _             _              = False
-\end{code}
-
-Auxiliary functions
-
-\begin{code}
-locallyBoundL, locallyBoundR :: RnEnv2 -> Var -> Bool
-locallyBoundL rn_env v = inRnEnvL rn_env v
-locallyBoundR rn_env v = inRnEnvR rn_env v
-
-
-expandUnfolding :: Unfolding -> Maybe CoreExpr
-expandUnfolding unfolding
-  | isExpandableUnfolding unfolding = Just (unfoldingTemplate unfolding)
-  | otherwise                      = Nothing
-\end{code}
-

 %************************************************************************
 %*                                                                     *
                    Rule-check the program                                                                              
 %************************************************************************
 %*                                                                     *
                    Rule-check the program