For a non-recursive let, make sure we extend the value environment

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

diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 028ec83..8ff1edc 100644 (file)
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -22,9 +22,9 @@ module Rules (
        addIdSpecialisations, 
        
        -- * Misc. CoreRule helpers
        addIdSpecialisations, 
        
        -- * Misc. CoreRule helpers

-        rulesOfBinds, getRules, pprRulesForUser,
+        rulesOfBinds, getRules, pprRulesForUser, 

         
         

-        lookupRule, 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

@@ -45,18 +45,82 @@ import VarSet
 import Name            ( Name, NamedThing(..) )
 import NameEnv
 import Unify           ( ruleMatchTyX, MatchEnv(..) )
 import Name            ( Name, NamedThing(..) )
 import NameEnv
 import Unify           ( ruleMatchTyX, MatchEnv(..) )

-import BasicTypes      ( Activation )
+import BasicTypes      ( Activation, CompilerPhase, isActive )

 import StaticFlags     ( opt_PprStyle_Debug )
 import Outputable
 import FastString
 import Maybes
 import StaticFlags     ( opt_PprStyle_Debug )
 import Outputable
 import FastString
 import Maybes

-import OrdList

 import Bag
 import Util
 import Data.List
 \end{code}
 
 
 import Bag
 import Util
 import Data.List
 \end{code}
 
 

+Note [Overall plumbing for rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* 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
+  that module.  The HomePackageTable grows as ghc --make does its
+  up-sweep.  In batch mode (ghc -c), the HPT is empty; all imported modules
+  are treated by the "external" route, discussed next, regardless of
+  which package they come from.
+
+* The ExternalPackageState has a single eps_rule_base :: RuleBase for
+  Ids in other packages.  This RuleBase simply grow monotonically, as
+  ghc --make compiles one module after another.
+
+  During simplification, interface files may get demand-loaded,
+  as the simplifier explores the unfoldings for Ids it has in 
+  its hand.  (Via an unsafePerformIO; the EPS is really a cache.)
+  That in turn may make the EPS rule-base grow.  In contrast, the
+  HPT never grows in this way.
+
+* The result of all this is that during Core-to-Core optimisation
+  there are four sources of rules:
+
+    (a) Rules in the IdInfo of the Id they are a rule for.  These are
+        easy: fast to look up, and if you apply a substitution then
+        it'll be applied to the IdInfo as a matter of course.
+
+    (b) Rules declared in this module for imported Ids, kept in the
+        ModGuts. If you do a substitution, you'd better apply the
+        substitution to these.  There are seldom many of these.
+
+    (c) Rules declared in the HomePackageTable.  These never change.
+
+    (d) Rules in the ExternalPackageTable. These can grow in response
+        to lazy demand-loading of interfaces.
+
+* At the moment (c) is carried in a reader-monad way by the CoreMonad.
+  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 why we can't just select the home-package RuleBase
+  from HscEnv.
+
+  [NB: we are inconsistent here.  We should do the same for external
+  pacakges, but we don't.  Same for type-class instances.]
+
+* So in the outer simplifier loop, we combine (b-d) into a single
+  RuleBase, reading 
+     (b) from the ModGuts, 
+     (c) from the CoreMonad, and
+     (d) from its mutable variable
+  [Of coures this means that we won't see new EPS rules that come in
+  during a single simplifier iteration, but that probably does not
+  matter.]
+
+

 %************************************************************************
 %*                                                                     *
 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
 %************************************************************************
 %*                                                                     *
 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}

@@ -92,15 +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
+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'
 -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being 
 -- compiled. See also 'CoreSyn.CoreRule'

-mkLocalRule 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,
   = Rule { ru_name = name, ru_fn = fn, ru_act = act,
           ru_bndrs = bndrs, ru_args = args,

-          ru_rhs = rhs, ru_rough = roughTopNames args,
-          ru_local = True }
+          ru_rhs = occurAnalyseExpr rhs, 
+          ru_rough = roughTopNames args,
+          ru_auto = is_auto, ru_local = is_local }

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

@@ -192,18 +257,32 @@ rulesOfBinds :: [CoreBind] -> [CoreRule]
 rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds
 
 getRules :: RuleBase -> Id -> [CoreRule]
 rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds
 
 getRules :: RuleBase -> Id -> [CoreRule]

-       -- The rules for an Id come from two places:
-       --      (a) the ones it is born with (idCoreRules fn)
-       --      (b) rules added in subsequent modules (extra_rules)
-       -- PrimOps, for example, are born with a bunch of rules under (a)
+-- See Note [Where rules are found]

 getRules rule_base fn
 getRules rule_base fn

-  | isLocalId fn  = idCoreRules fn
-  | otherwise     = WARN( not (isPrimOpId fn) && notNull (idCoreRules fn), 
-                         ppr fn <+> ppr (idCoreRules fn) )
-                   idCoreRules fn ++ (lookupNameEnv rule_base (idName fn) `orElse` [])
-       -- Only PrimOpIds have rules inside themselves, and perhaps more besides
+  = idCoreRules fn ++ imp_rules
+  where
+    imp_rules = lookupNameEnv rule_base (idName fn) `orElse` []

 \end{code}
 
 \end{code}
 

+Note [Where rules are found]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The rules for an Id come from two places:
+  (a) the ones it is born with, stored inside the Id iself (idCoreRules fn),
+  (b) rules added in other modules, stored in the global RuleBase (imp_rules)
+
+It's tempting to think that 
+     - LocalIds have only (a)
+     - non-LocalIds have only (b)
+
+but that isn't quite right:
+
+     - PrimOps and ClassOps are born with a bunch of rules inside the Id,
+       even when they are imported
+
+     - The rules in PrelRules.builtinRules should be active even
+       in the module defining the Id (when it's a LocalId), but 
+       the rules are kept in the global RuleBase
+

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

@@ -242,38 +321,24 @@ 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
 -- context, returning the rule applied and the resulting expression if
 -- successful.
 \begin{code}
 -- | The main rule matching function. Attempts to apply all (active)
 -- supplied rules to this instance of an application in a given
 -- context, returning the rule applied and the resulting expression if
 -- successful.

-lookupRule :: (Activation -> Bool) -> InScopeSet
+lookupRule :: (Activation -> Bool)     -- When rule is active
+           -> IdUnfoldingFun           -- When Id can be unfolded
+            -> InScopeSet

            -> Id -> [CoreExpr]
            -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
 
 -- See Note [Extra args in rule matching]
 -- See comments on matchRule
            -> Id -> [CoreExpr]
            -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
 
 -- See Note [Extra args in rule matching]
 -- See comments on matchRule

-lookupRule is_active in_scope fn args rules
+lookupRule is_active id_unf in_scope fn args rules

   = -- pprTrace "matchRules" (ppr fn <+> ppr rules) $
     case go [] rules of
        []     -> Nothing
   = -- pprTrace "matchRules" (ppr fn <+> ppr rules) $
     case go [] rules of
        []     -> Nothing

@@ -283,11 +348,14 @@ lookupRule is_active in_scope fn args rules
 
     go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
     go ms []          = ms
 
     go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
     go ms []          = ms

-    go ms (r:rs) = case (matchRule is_active in_scope args rough_args r) of
+    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 $$ 
                        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)

@@ -314,20 +382,51 @@ 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 })
 isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 })
               (Rule { ru_bndrs = bndrs2, ru_args = args2 })

-  = isJust (matchN in_scope bndrs2 args2 args1)
+  = isJust (matchN id_unfolding_fun in_scope bndrs2 args2 args1)

   where
   where

+   id_unfolding_fun _ = NoUnfolding    -- Don't expand in templates

    in_scope = mkInScopeSet (mkVarSet bndrs1)
        -- Actually we should probably include the free vars 
        -- of rule1's args, but I can't be bothered
 
 noBlackList :: Activation -> Bool
 noBlackList _ = False          -- Nothing is black listed
    in_scope = mkInScopeSet (mkVarSet bndrs1)
        -- Actually we should probably include the free vars 
        -- of rule1's args, but I can't be bothered
 
 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

 
 

-matchRule :: (Activation -> Bool) -> InScopeSet
+\begin{code}
+------------------------------------
+matchRule :: (Activation -> Bool) -> IdUnfoldingFun
+          -> InScopeSet

          -> [CoreExpr] -> [Maybe Name]
          -> CoreRule -> Maybe CoreExpr
 
          -> [CoreExpr] -> [Maybe Name]
          -> CoreRule -> Maybe CoreExpr
 

@@ -353,43 +452,44 @@ matchRule :: (Activation -> Bool) -> InScopeSet
 -- Any 'surplus' arguments in the input are simply put on the end
 -- of the output.
 
 -- Any 'surplus' arguments in the input are simply put on the end
 -- of the output.
 

-matchRule _is_active _in_scope args _rough_args
+matchRule _is_active id_unf _in_scope args _rough_args

          (BuiltinRule { ru_try = match_fn })
          (BuiltinRule { ru_try = match_fn })

-  = case match_fn args of
+-- Built-in rules can't be switched off, it seems
+  = case match_fn id_unf args of

        Just expr -> Just expr
        Nothing   -> Nothing
 
        Just expr -> Just expr
        Nothing   -> Nothing
 

-matchRule is_active in_scope args rough_args
+matchRule is_active id_unf in_scope args rough_args

           (Rule { ru_act = act, ru_rough = tpl_tops,
                  ru_bndrs = tpl_vars, ru_args = tpl_args,
                  ru_rhs = rhs })
   | not (is_active act)                      = Nothing
   | ruleCantMatch tpl_tops rough_args = Nothing
   | otherwise
           (Rule { ru_act = act, ru_rough = tpl_tops,
                  ru_bndrs = tpl_vars, ru_args = tpl_args,
                  ru_rhs = rhs })
   | not (is_active act)                      = Nothing
   | ruleCantMatch tpl_tops rough_args = Nothing
   | otherwise

-  = case matchN in_scope tpl_vars tpl_args args of
-       Nothing                -> Nothing
-       Just (binds, tpl_vals) -> Just (mkLets binds $
-                                       rule_fn `mkApps` tpl_vals)
+  = case matchN id_unf in_scope tpl_vars tpl_args args of
+       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 :: InScopeSet           -- ^ In-scope variables
+---------------------------------------
+matchN :: IdUnfoldingFun
+        -> InScopeSet           -- ^ In-scope variables

        -> [Var]                -- ^ Match template type variables
        -> [CoreExpr]           -- ^ Match template
        -> [CoreExpr]           -- ^ Target; can have more elements than the template
        -> [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 in_scope tmpl_vars 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
   = 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

@@ -399,12 +499,12 @@ matchN in_scope tmpl_vars tmpl_es target_es
                
     go _    subst []     _     = Just subst
     go _    _     _      []    = Nothing       -- Fail if too few actual args
                
     go _    subst []     _     = Just subst
     go _    _     _      []    = Nothing       -- Fail if too few actual args

-    go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e 
+    go menv subst (t:ts) (e:es) = do { subst1 <- match id_unf menv subst t e 

                                     ; go menv subst1 ts es }
 
     lookup_tmpl :: TvSubstEnv -> IdSubstEnv -> Var -> CoreExpr
     lookup_tmpl tv_subst id_subst tmpl_var'
                                     ; go menv subst1 ts es }
 
     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

@@ -443,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.

@@ -462,7 +566,8 @@ emptySubstEnv = (emptyVarEnv, emptyVarEnv, nilOL)
 --     SLPJ July 99
 
 
 --     SLPJ July 99
 
 

-match :: MatchEnv
+match :: IdUnfoldingFun
+      -> MatchEnv

       -> SubstEnv
       -> CoreExpr              -- Template
       -> CoreExpr              -- Target
       -> SubstEnv
       -> CoreExpr              -- Template
       -> CoreExpr              -- Target

@@ -484,52 +589,62 @@ match :: MatchEnv
 -- succeed in matching what looks like the template variable 'a' against 3.
 
 -- The Var case follows closely what happens in Unify.match
 -- succeed in matching what looks like the template variable 'a' against 3.
 
 -- The Var case follows closely what happens in Unify.match

-match menv subst (Var v1) e2 
-  | Just subst <- match_var menv subst v1 e2
+match idu menv subst (Var v1) e2 
+  | Just subst <- match_var idu menv subst v1 e2

   = Just subst
 
   = Just subst
 

-match menv subst (Note _ e1) e2 = match menv subst e1 e2
-match menv subst e1 (Note _ e2) = match menv subst e1 e2
+match idu menv subst (Note _ e1) e2 = match idu menv subst e1 e2
+match idu menv subst e1 (Note _ e2) = match idu menv subst e1 e2

       -- Ignore notes in both template and thing to be matched
       -- See Note [Notes in RULE matching]
 
       -- Ignore notes in both template and thing to be matched
       -- See Note [Notes in RULE matching]
 

-match menv subst e1 (Var v2)      -- Note [Expanding variables]
-  | not (locallyBoundR rn_env v2) -- Note [Do not expand locally-bound variables]
-  , Just e2' <- expandId v2'
-  = match (menv { me_env = nukeRnEnvR rn_env }) subst e1 e2'
+match id_unfolding_fun menv subst e1 (Var v2)      -- Note [Expanding variables]
+  | 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
     rn_env = me_env menv
        -- 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)
   where
     v2'    = lookupRnInScope rn_env v2
     rn_env = me_env menv
        -- 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
-
-match 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)
-  = match (menv { me_env = rn_env' }) 
-         (tv_subst, id_subst, binds `snocOL` bind')
-         e1 e2'
+       -- because of the not-inRnEnvR
+
+match idu menv (tv_subst, id_subst, binds) e1 (Let bind e2)
+  | okToFloat rn_env bndrs (bindFreeVars bind)         -- See Note [Matching lets]
+  = match idu (menv { me_env = rn_env' }) 
+         (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)
+match _ _ subst (Lit lit1) (Lit lit2)

   | lit1 == lit2
   = Just subst
 
   | lit1 == lit2
   = Just subst
 

-match menv subst (App f1 a1) (App f2 a2)
-  = do         { subst' <- match menv subst f1 f2
-       ; match menv subst' a1 a2 }
+match idu menv subst (App f1 a1) (App f2 a2)
+  = do         { subst' <- match idu menv subst f1 f2
+       ; match idu menv subst' a1 a2 }

 
 

-match menv subst (Lam x1 e1) (Lam x2 e2)
-  = match menv' subst e1 e2
+match idu menv subst (Lam x1 e1) (Lam x2 e2)
+  = match idu menv' subst e1 e2

   where
     menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 }
 
   where
     menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 }
 

@@ -538,45 +653,55 @@ match menv subst (Lam x1 e1) (Lam x2 e2)
 -- 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
 -- 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))
+match idu menv subst (Lam x1 e1) e2
+  = match idu menv' subst e1 (App e2 (varToCoreExpr new_x))

   where
   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
 --     M  ~  (\y.N)    iff   M y     ~  N
     menv' = menv { me_env = rn_env' }
 
 -- Eta expansion the other way
 --     M  ~  (\y.N)    iff   M y     ~  N

-match menv subst e1 (Lam x2 e2)
-  = match menv' subst (App e1 (varToCoreExpr new_x)) e2
+match idu menv subst e1 (Lam x2 e2)
+  = match idu menv' subst (App e1 (varToCoreExpr new_x)) e2

   where
   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' }
 
     menv' = menv { me_env = rn_env' }
 

-match menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
+match idu menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)

   = do { subst1 <- match_ty menv subst ty1 ty2
   = do { subst1 <- match_ty menv subst ty1 ty2

-       ; subst2 <- match menv subst1 e1 e2
+       ; subst2 <- match idu menv subst1 e1 e2

        ; let menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 }
        ; let menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 }

-       ; match_alts menv' subst2 alts1 alts2   -- Alts are both sorted
+       ; match_alts idu menv' subst2 alts1 alts2       -- Alts are both sorted

        }
 
        }
 

-match menv subst (Type ty1) (Type ty2)
+match _ menv subst (Type ty1) (Type ty2)

   = match_ty menv subst ty1 ty2
 
   = match_ty menv subst ty1 ty2
 

-match menv subst (Cast e1 co1) (Cast e2 co2)
+match idu menv subst (Cast e1 co1) (Cast e2 co2)

   = do { subst1 <- match_ty menv subst co1 co2
   = do { subst1 <- match_ty menv subst co1 co2

-       ; match menv subst1 e1 e2 }
+       ; match idu menv subst1 e1 e2 }

 
 -- Everything else fails
 
 -- Everything else fails

-match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ 
+match _ _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ 

                         Nothing
 
 ------------------------------------------
                         Nothing
 
 ------------------------------------------

-match_var :: MatchEnv
+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
          -> Var                -- Template
          -> CoreExpr           -- Target
          -> Maybe SubstEnv
          -> SubstEnv
          -> Var                -- Template
          -> CoreExpr           -- Target
          -> Maybe SubstEnv

-match_var menv subst@(tv_subst, id_subst, binds) v1 e2
+match_var idu menv subst@(tv_subst, id_subst, binds) v1 e2

   | v1' `elemVarSet` me_tmpls menv
   = case lookupVarEnv id_subst v1' of
        Nothing | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2))
   | v1' `elemVarSet` me_tmpls menv
   = case lookupVarEnv id_subst v1' of
        Nothing | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2))

@@ -599,7 +724,7 @@ match_var 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 (nukeRnEnvL rn_env) e1' e2 
+       Just e1' | eqExprX idu (nukeRnEnvL rn_env) e1' e2 

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

@@ -620,38 +745,37 @@ match_var menv subst@(tv_subst, id_subst, binds) v1 e2
                                
 
 ------------------------------------------
                                
 
 ------------------------------------------

-match_alts :: MatchEnv
-      -> SubstEnv
-      -> [CoreAlt]             -- Template
-      -> [CoreAlt]             -- Target
-      -> Maybe SubstEnv
-match_alts _ subst [] []
+match_alts :: IdUnfoldingFun
+           -> MatchEnv
+          -> SubstEnv
+          -> [CoreAlt]         -- Template
+          -> [CoreAlt]         -- Target
+          -> Maybe SubstEnv
+match_alts _ _ subst [] []

   = return subst
   = return subst

-match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
+match_alts idu menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)

   | c1 == c2
   | c1 == c2

-  = do { subst1 <- match menv' subst r1 r2
-       ; match_alts menv subst1 alts1 alts2 }
+  = do { subst1 <- match idu menv' subst r1 r2
+       ; match_alts idu menv subst1 alts1 alts2 }

   where
     menv' :: MatchEnv
     menv' = menv { me_env = rnBndrs2 (me_env menv) vs1 vs2 }
 
   where
     menv' :: MatchEnv
     menv' = menv { me_env = rnBndrs2 (me_env menv) vs1 vs2 }
 

-match_alts _ _ _ _
+match_alts _ _ _ _ _

   = Nothing
   = 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) }

@@ -704,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 

@@ -736,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

@@ -772,82 +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 :: 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 env (Var v1) e2
-  | not (locallyBoundL env v1)
-  , Just e1' <- expandId (lookupRnInScope env v1)
-  = eqExpr (nukeRnEnvL env) e1' e2
-
-eqExpr env e1 (Var v2)
-  | not (locallyBoundR env v2)
-  , Just e2' <- expandId (lookupRnInScope env v2)
-  = eqExpr (nukeRnEnvR env) e1 e2'
-
-eqExpr _   (Lit lit1)    (Lit lit2)    = lit1 == lit2
-eqExpr env (App f1 a1)   (App f2 a2)   = eqExpr env f1 f2 && eqExpr env a1 a2
-eqExpr env (Lam v1 e1)   (Lam v2 e2)   = eqExpr (rnBndr2 env v1 v2) e1 e2
-eqExpr env (Note n1 e1)  (Note n2 e2)  = eq_note env n1 n2 && eqExpr env e1 e2
-eqExpr env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && eqExpr env e1 e2
-eqExpr env (Type t1)     (Type t2)     = tcEqTypeX env t1 t2
-
-eqExpr env (Let (NonRec v1 r1) e1)
-          (Let (NonRec v2 r2) e2) =  eqExpr env r1 r2 
-                                  && eqExpr (rnBndr2 env v1 v2) e1 e2
-eqExpr env (Let (Rec ps1) e1)
-          (Let (Rec ps2) e2)      =  equalLength ps1 ps2
-                                  && and (zipWith eq_rhs ps1 ps2)
-                                  && eqExpr 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 env' r1 r2
-eqExpr env (Case e1 v1 t1 a1)
-          (Case e2 v2 t2 a2) =  eqExpr env e1 e2
-                              && tcEqTypeX env t1 t2                      
-                             && equalLength a1 a2
-                             && and (zipWith (eq_alt env') a1 a2)
-                             where
-                               env' = rnBndr2 env v1 v2
-
-eqExpr _   _             _             = False
-
-eq_alt :: RnEnv2 -> CoreAlt -> CoreAlt -> Bool
-eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && eqExpr (rnBndrs2 env vs1  vs2) r1 r2
-
-eq_note :: RnEnv2 -> Note -> Note -> Bool
-eq_note _ (SCC cc1)     (SCC cc2)      = cc1 == cc2
-eq_note _ (CoreNote s1) (CoreNote s2)  = s1 == s2
-eq_note _ (InlineMe)    (InlineMe)     = True
-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
-
-
-expandId :: Id -> Maybe CoreExpr
-expandId id
-  | isExpandableUnfolding unfolding = Just (unfoldingTemplate unfolding)
-  | otherwise                      = Nothing
-  where
-    unfolding = idUnfolding id
-\end{code}
-

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

@@ -860,12 +926,12 @@ expandId id
 \begin{code}
 -- | Report partial matches for rules beginning with the specified
 -- string for the purposes of error reporting
 \begin{code}
 -- | Report partial matches for rules beginning with the specified
 -- string for the purposes of error reporting

-ruleCheckProgram :: (Activation -> Bool)    -- ^ Rule activation test
+ruleCheckProgram :: CompilerPhase               -- ^ Rule activation test

                  -> String                      -- ^ Rule pattern
                  -> RuleBase                    -- ^ Database of rules
                  -> [CoreBind]                  -- ^ Bindings to check in
                  -> SDoc                        -- ^ Resulting check message
                  -> String                      -- ^ Rule pattern
                  -> RuleBase                    -- ^ Database of rules
                  -> [CoreBind]                  -- ^ Bindings to check in
                  -> SDoc                        -- ^ Resulting check message

-ruleCheckProgram is_active rule_pat rule_base binds 
+ruleCheckProgram phase rule_pat rule_base binds 

   | isEmptyBag results
   = text "Rule check results: no rule application sites"
   | otherwise
   | isEmptyBag results
   = text "Rule check results: no rule application sites"
   | otherwise

@@ -874,11 +940,17 @@ ruleCheckProgram is_active rule_pat rule_base binds
          vcat [ p $$ line | p <- bagToList results ]
         ]
   where
          vcat [ p $$ line | p <- bagToList results ]
         ]
   where

-    results = unionManyBags (map (ruleCheckBind (RuleCheckEnv is_active rule_pat rule_base)) binds)
+    env = RuleCheckEnv { rc_is_active = isActive phase
+                       , rc_id_unf    = idUnfolding    -- Not quite right
+                                                       -- Should use activeUnfolding
+                       , rc_pattern   = rule_pat
+                       , rc_rule_base = rule_base }
+    results = unionManyBags (map (ruleCheckBind env) binds)

     line = text (replicate 20 '-')
          
 data RuleCheckEnv = RuleCheckEnv {
     rc_is_active :: Activation -> Bool, 
     line = text (replicate 20 '-')
          
 data RuleCheckEnv = RuleCheckEnv {
     rc_is_active :: Activation -> Bool, 

+    rc_id_unf  :: IdUnfoldingFun,

     rc_pattern :: String, 
     rc_rule_base :: RuleBase
 }
     rc_pattern :: String, 
     rc_rule_base :: RuleBase
 }

@@ -913,13 +985,13 @@ ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
 
 ruleCheckFun env fn args
   | null name_match_rules = emptyBag
 
 ruleCheckFun env fn args
   | null name_match_rules = emptyBag

-  | otherwise            = unitBag (ruleAppCheck_help (rc_is_active env) fn args name_match_rules)
+  | otherwise            = unitBag (ruleAppCheck_help env fn args name_match_rules)

   where
     name_match_rules = filter match (getRules (rc_rule_base env) fn)
     match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule)
 
   where
     name_match_rules = filter match (getRules (rc_rule_base env) fn)
     match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule)
 

-ruleAppCheck_help :: (Activation -> Bool) -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
-ruleAppCheck_help is_active fn args rules
+ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
+ruleAppCheck_help env fn args rules

   =    -- The rules match the pattern, so we want to print something
     vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
          vcat (map check_rule rules)]
   =    -- The rules match the pattern, so we want to print something
     vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
          vcat (map check_rule rules)]

@@ -936,14 +1008,14 @@ ruleAppCheck_help is_active fn args rules
        = ptext (sLit "Rule") <+> doubleQuotes (ftext name)
 
     rule_info rule
        = ptext (sLit "Rule") <+> doubleQuotes (ftext name)
 
     rule_info rule

-       | Just _ <- matchRule noBlackList emptyInScopeSet args rough_args rule
+       | Just _ <- matchRule noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule

        = text "matches (which is very peculiar!)"
 
     rule_info (BuiltinRule {}) = text "does not match"
 
     rule_info (Rule { ru_act = act, 
                      ru_bndrs = rule_bndrs, ru_args = rule_args})
        = text "matches (which is very peculiar!)"
 
     rule_info (BuiltinRule {}) = text "does not match"
 
     rule_info (Rule { ru_act = act, 
                      ru_bndrs = rule_bndrs, ru_args = rule_args})

-       | not (is_active act)    = text "active only in later phase"
+       | not (rc_is_active env act)  = text "active only in later phase"

        | n_args < n_rule_args        = text "too few arguments"
        | n_mismatches == n_rule_args = text "no arguments match"
        | n_mismatches == 0           = text "all arguments match (considered individually), but rule as a whole does not"
        | n_args < n_rule_args        = text "too few arguments"
        | n_mismatches == n_rule_args = text "no arguments match"
        | n_mismatches == 0           = text "all arguments match (considered individually), but rule as a whole does not"

@@ -955,7 +1027,7 @@ ruleAppCheck_help is_active fn args rules
                              not (isJust (match_fn rule_arg arg))]
 
          lhs_fvs = exprsFreeVars rule_args     -- Includes template tyvars
                              not (isJust (match_fn rule_arg arg))]
 
          lhs_fvs = exprsFreeVars rule_args     -- Includes template tyvars

-         match_fn rule_arg arg = match menv emptySubstEnv rule_arg arg
+         match_fn rule_arg arg = match (rc_id_unf env) menv emptySubstEnv rule_arg arg

                where
                  in_scope = lhs_fvs `unionVarSet` exprFreeVars arg
                  menv = ME { me_env   = mkRnEnv2 (mkInScopeSet in_scope)
                where
                  in_scope = lhs_fvs `unionVarSet` exprFreeVars arg
                  menv = ME { me_env   = mkRnEnv2 (mkInScopeSet in_scope)