Trim redundant import

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

diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 92d3fbc..39a9f05 100644 (file)
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -4,15 +4,33 @@
 \section[CoreRules]{Transformation rules}
 
 \begin{code}
 \section[CoreRules]{Transformation rules}
 
 \begin{code}

+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
+-- | Functions for collecting together and applying rewrite rules to a module.
+-- The 'CoreRule' datatype itself is declared elsewhere.

 module Rules (
 module Rules (

-       RuleBase, emptyRuleBase, mkRuleBase, extendRuleBaseList, 
-       unionRuleBase, pprRuleBase, ruleCheckProgram,
+       -- * RuleBase
+       RuleBase, 
+       
+       -- ** Constructing 
+       emptyRuleBase, mkRuleBase, extendRuleBaseList, 
+       unionRuleBase, pprRuleBase, 
+       
+       -- ** Checking rule applications
+       ruleCheckProgram,

 
 

+        -- ** Manipulating 'SpecInfo' rules

        mkSpecInfo, extendSpecInfo, addSpecInfo,
        mkSpecInfo, extendSpecInfo, addSpecInfo,

-       rulesOfBinds, addIdSpecialisations, 
+       addIdSpecialisations, 

        
        

-       matchN,
-
+       -- * Misc. CoreRule helpers
+        rulesOfBinds, getRules, pprRulesForUser,
+        

         lookupRule, mkLocalRule, roughTopNames
     ) where
 
         lookupRule, mkLocalRule, roughTopNames
     ) where
 

@@ -20,16 +38,14 @@ module Rules (
 
 import CoreSyn         -- All of it
 import OccurAnal       ( occurAnalyseExpr )
 
 import CoreSyn         -- All of it
 import OccurAnal       ( occurAnalyseExpr )

-import CoreFVs         ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesRhsFreeVars )
-import CoreUnfold      ( isCheapUnfolding, unfoldingTemplate )
+import CoreFVs         ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars )

 import CoreUtils       ( tcEqExprX, exprType )
 import PprCore         ( pprRules )
 import Type            ( Type, TvSubstEnv )
 import Coercion         ( coercionKind )
 import TcType          ( tcSplitTyConApp_maybe )
 import CoreTidy                ( tidyRules )
 import CoreUtils       ( tcEqExprX, exprType )
 import PprCore         ( pprRules )
 import Type            ( Type, TvSubstEnv )
 import Coercion         ( coercionKind )
 import TcType          ( tcSplitTyConApp_maybe )
 import CoreTidy                ( tidyRules )

-import Id              ( Id, idUnfolding, isLocalId, isGlobalId, idName, idType,
-                         idSpecialisation, idCoreRules, setIdSpecialisation ) 
+import Id

 import IdInfo          ( SpecInfo( SpecInfo ) )
 import Var             ( Var )
 import VarEnv
 import IdInfo          ( SpecInfo( SpecInfo ) )
 import Var             ( Var )
 import VarEnv

@@ -37,14 +53,15 @@ 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, CompilerPhase, isActive )
+import BasicTypes      ( Activation )
+import StaticFlags     ( opt_PprStyle_Debug )

 import Outputable
 import FastString
 import Maybes
 import OrdList
 import Bag
 import Util
 import Outputable
 import FastString
 import Maybes
 import OrdList
 import Bag
 import Util

-import List hiding( mapAccumL )        -- Also defined in Util
+import Data.List

 \end{code}
 
 
 \end{code}
 
 

@@ -85,7 +102,8 @@ where pi' :: Lift Int# is the specialised version of pi.
 \begin{code}
 mkLocalRule :: RuleName -> Activation 
            -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
 \begin{code}
 mkLocalRule :: RuleName -> Activation 
            -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule

--- Used to make CoreRule for an Id defined in this module
+-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being 
+-- compiled. See also 'CoreSyn.CoreRule'

 mkLocalRule name act fn bndrs args rhs
   = Rule { ru_name = name, ru_fn = fn, ru_act = act,
           ru_bndrs = bndrs, ru_args = args,
 mkLocalRule name act fn bndrs args rhs
   = Rule { ru_name = name, ru_fn = fn, ru_act = act,
           ru_bndrs = bndrs, ru_args = args,

@@ -94,14 +112,19 @@ mkLocalRule name act fn bndrs args rhs
 
 --------------
 roughTopNames :: [CoreExpr] -> [Maybe Name]
 
 --------------
 roughTopNames :: [CoreExpr] -> [Maybe Name]

+-- ^ Find the \"top\" free names of several expressions. 
+-- Such names are either:
+--
+-- 1. The function finally being applied to in an application chain
+--    (if that name is a GlobalId: see "Var#globalvslocal"), or
+--
+-- 2. The 'TyCon' if the expression is a 'Type'
+--
+-- This is used for the fast-match-check for rules; 
+--     if the top names don't match, the rest can't

 roughTopNames args = map roughTopName args
 
 roughTopName :: CoreExpr -> Maybe Name
 roughTopNames args = map roughTopName args
 
 roughTopName :: CoreExpr -> Maybe Name

--- Find the "top" free name of an expression
--- a) the function in an App chain (if a GlobalId)
--- b) the TyCon in a type
--- This is used for the fast-match-check for rules; 
---     if the top names don't match, the rest can't

 roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of
                          Just (tc,_) -> Just (getName tc)
                          Nothing     -> Nothing
 roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of
                          Just (tc,_) -> Just (getName tc)
                          Nothing     -> Nothing

@@ -111,21 +134,39 @@ roughTopName (Var f) | isGlobalId f = Just (idName f)
 roughTopName other = Nothing
 
 ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
 roughTopName other = Nothing
 
 ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool

--- (ruleCantMatch tpl actual) returns True only if 'actual'
--- definitely can't match 'tpl' by instantiating 'tpl'.  
+-- ^ @ruleCantMatch tpl actual@ returns True only if @actual@
+-- definitely can't match @tpl@ by instantiating @tpl@.  

 -- It's only a one-way match; unlike instance matching we 
 -- It's only a one-way match; unlike instance matching we 

--- don't consider unification
+-- don't consider unification.

 -- 
 -- 

--- Notice that there is no case
---     ruleCantMatch (Just n1 : ts) (Nothing : as) = True
--- Reason: a local variable 'v' in the actuals might 
---        have an unfolding which is a global.
---        This quite often happens with case scrutinees.
+-- Notice that [_$_]
+--     @ruleCantMatch [Nothing] [Just n2] = False@
+--      Reason: a template variable can be instantiated by a constant
+-- Also:
+--     @ruleCantMatch [Just n1] [Nothing] = False@
+--      Reason: a local variable @v@ in the actuals might [_$_]
+

 ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as
 ruleCantMatch (t       : ts) (a       : as) = ruleCantMatch ts as
 ruleCantMatch ts            as             = False
 \end{code}
 
 ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as
 ruleCantMatch (t       : ts) (a       : as) = ruleCantMatch ts as
 ruleCantMatch ts            as             = False
 \end{code}
 

+\begin{code}
+pprRulesForUser :: [CoreRule] -> SDoc
+-- (a) tidy the rules
+-- (b) sort them into order based on the rule name
+-- (c) suppress uniques (unless -dppr-debug is on)
+-- This combination makes the output stable so we can use in testing
+-- It's here rather than in PprCore because it calls tidyRules
+pprRulesForUser rules
+  = withPprStyle defaultUserStyle $
+    pprRules $
+    sortLe le_rule  $
+    tidyRules emptyTidyEnv rules
+  where 
+    le_rule r1 r2 = ru_name r1 <= ru_name r2
+\end{code}
+

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

@@ -134,12 +175,14 @@ ruleCantMatch ts       as             = False
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

+-- | Make a 'SpecInfo' containing a number of 'CoreRule's, suitable
+-- for putting into an 'IdInfo'

 mkSpecInfo :: [CoreRule] -> SpecInfo
 mkSpecInfo :: [CoreRule] -> SpecInfo

-mkSpecInfo rules = SpecInfo rules (rulesRhsFreeVars rules)
+mkSpecInfo rules = SpecInfo rules (rulesFreeVars rules)

 
 extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo
 extendSpecInfo (SpecInfo rs1 fvs1) rs2
 
 extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo
 extendSpecInfo (SpecInfo rs1 fvs1) rs2

-  = SpecInfo (rs2 ++ rs1) (rulesRhsFreeVars rs2 `unionVarSet` fvs1)
+  = SpecInfo (rs2 ++ rs1) (rulesFreeVars rs2 `unionVarSet` fvs1)

 
 addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo
 addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2) 
 
 addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo
 addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2) 

@@ -150,8 +193,21 @@ addIdSpecialisations id rules
   = setIdSpecialisation id $
     extendSpecInfo (idSpecialisation id) rules
 
   = setIdSpecialisation id $
     extendSpecInfo (idSpecialisation id) rules
 

+-- | Gather all the rules for locally bound identifiers from the supplied bindings

 rulesOfBinds :: [CoreBind] -> [CoreRule]
 rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds
 rulesOfBinds :: [CoreBind] -> [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)
+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

 \end{code}
 
 
 \end{code}
 
 

@@ -162,8 +218,8 @@ rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

+-- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules

 type RuleBase = NameEnv [CoreRule]
 type RuleBase = NameEnv [CoreRule]

-       -- Maps (the name of) an Id to its rules

        -- The rules are are unordered; 
        -- we sort out any overlaps on lookup
 
        -- The rules are are unordered; 
        -- we sort out any overlaps on lookup
 

@@ -195,26 +251,34 @@ pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs)
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

+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}
 \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) -> InScopeSet

-          -> RuleBase  -- Imported rules
-          -> Id -> [CoreExpr] -> Maybe (CoreRule, CoreExpr)
-lookupRule is_active in_scope rule_base fn args
-  = matchRules is_active in_scope fn args rules
-  where
-       -- 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)
-    rules = extra_rules ++ idCoreRules fn
-    extra_rules | isLocalId fn = []
-               | otherwise    = lookupNameEnv rule_base (idName fn) `orElse` []
+           -> Id -> [CoreExpr]
+           -> [CoreRule] -> Maybe (CoreRule, CoreExpr)

 
 

-matchRules :: (Activation -> Bool) -> InScopeSet
-          -> Id -> [CoreExpr]
-          -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
+-- See Note [Extra args in rule matching]

 -- See comments on matchRule
 -- See comments on matchRule

-matchRules is_active in_scope fn args rules
+lookupRule is_active 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

@@ -227,7 +291,7 @@ matchRules is_active in_scope fn args rules
     go ms (r:rs) = case (matchRule is_active 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 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] )
+                                  --   ppr [(arg_id, unfoldingTemplate unf) | Var arg_id <- args, let unf = idUnfolding arg_id, isCheapUnfolding unf] )

                                   go ms         rs
 
 findBest :: (Id, [CoreExpr])
                                   go ms         rs
 
 findBest :: (Id, [CoreExpr])

@@ -240,15 +304,17 @@ findBest target (rule,ans)   [] = (rule,ans)
 findBest target (rule1,ans1) ((rule2,ans2):prs)
   | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs
   | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs
 findBest target (rule1,ans1) ((rule2,ans2):prs)
   | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs
   | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs

-#ifdef DEBUG
-  | otherwise = pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"
-                        (vcat [ptext SLIT("Expression to match:") <+> ppr fn <+> sep (map ppr args),
-                               ptext SLIT("Rule 1:") <+> ppr rule1, 
-                               ptext SLIT("Rule 2:") <+> ppr rule2]) $
+  | debugIsOn = let pp_rule rule
+                       | opt_PprStyle_Debug = ppr rule
+                       | otherwise          = doubleQuotes (ftext (ru_name rule))
+               in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"
+                        (vcat [if opt_PprStyle_Debug then 
+                                  ptext (sLit "Expression to match:") <+> ppr fn <+> sep (map ppr args)
+                               else empty,
+                               ptext (sLit "Rule 1:") <+> pp_rule rule1, 
+                               ptext (sLit "Rule 2:") <+> pp_rule rule2]) $

                findBest target (rule1,ans1) prs
                findBest target (rule1,ans1) prs

-#else

   | otherwise = findBest target (rule1,ans1) prs
   | otherwise = findBest target (rule1,ans1) prs

-#endif

   where
     (fn,args) = target
 
   where
     (fn,args) = target
 

@@ -315,12 +381,15 @@ matchRule is_active in_scope args rough_args
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-matchN :: InScopeSet
-       -> [Var]                -- Template tyvars
-       -> [CoreExpr]           -- Template
-       -> [CoreExpr]           -- Target; can have more elts than template
-       -> Maybe ([CoreBind],   -- Bindings to wrap around the entire result
-                 [CoreExpr])   -- What is substituted for each template var
+-- 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
+       -> [Var]                -- ^ Match template type variables
+       -> [CoreExpr]           -- ^ Match template
+       -> [CoreExpr]           -- ^ Target; can have more elements than the template
+       -> Maybe ([CoreBind],
+                 [CoreExpr])

 
 matchN in_scope tmpl_vars tmpl_es target_es
   = do { (tv_subst, id_subst, binds)
 
 matchN in_scope tmpl_vars tmpl_es target_es
   = do { (tv_subst, id_subst, binds)

@@ -565,11 +634,8 @@ match menv subst (Type ty1) (Type ty2)
   = match_ty menv subst ty1 ty2
 
 match menv subst (Cast e1 co1) (Cast e2 co2)
   = match_ty menv subst ty1 ty2
 
 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 }
+  = do { subst1 <- match_ty menv subst co1 co2
+       ; match menv subst1 e1 e2 }

 
 {-     REMOVING OLD CODE: I think that the above handling for let is 
                           better than the stuff here, which looks 
 
 {-     REMOVING OLD CODE: I think that the above handling for let is 
                           better than the stuff here, which looks 

@@ -616,6 +682,8 @@ match_var menv subst@(tv_subst, id_subst, binds) v1 e2
 
                | otherwise     -- No renaming to do on e2, because no free var
                                -- of e2 is in the rnEnvR of the envt
 
                | otherwise     -- No renaming to do on e2, because no free var
                                -- of e2 is in the rnEnvR of the envt

+               -- Note [Matching variable types]
+               -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

                -- However, we must match the *types*; e.g.
                --   forall (c::Char->Int) (x::Char). 
                --      f (c x) = "RULE FIRED"
                -- However, we must match the *types*; e.g.
                --   forall (c::Char->Int) (x::Char). 
                --      f (c x) = "RULE FIRED"

@@ -700,19 +768,19 @@ SpecConstr sees this fragment:
          Data.Maybe.Nothing -> lvl_smf;
          Data.Maybe.Just n_acT [Just S(L)] ->
            case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] ->
          Data.Maybe.Nothing -> lvl_smf;
          Data.Maybe.Just n_acT [Just S(L)] ->
            case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] ->

-           $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
+           \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf

            }};
 
 and correctly generates the rule
 
        RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int#
                                          sc_snn :: GHC.Prim.Int#}
            }};
 
 and correctly generates the rule
 
        RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int#
                                          sc_snn :: GHC.Prim.Int#}

-         $wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr))
-         = $s$wfoo_sno y_amr sc_snn ;]
+         \$wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr))
+         = \$s\$wfoo_sno y_amr sc_snn ;]

 
 BUT we must ensure that this rule matches in the original function!
 
 BUT we must ensure that this rule matches in the original function!

-Note that the call to $wfoo is
-           $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
+Note that the call to \$wfoo is
+           \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf

 
 During matching we expand wild_Xf to (Just n_acT).  But then we must also
 expand n_acT to (I# y_amr).  And we can only do that if we look up n_acT
 
 During matching we expand wild_Xf to (Just n_acT).  But then we must also
 expand n_acT to (I# y_amr).  And we can only do that if we look up n_acT

@@ -736,16 +804,15 @@ is so important.
 We want to know what sites have rules that could have fired but didn't.
 This pass runs over the tree (without changing it) and reports such.
 
 We want to know what sites have rules that could have fired but didn't.
 This pass runs over the tree (without changing it) and reports such.
 

-NB: we assume that this follows a run of the simplifier, so every Id
-occurrence (including occurrences of imported Ids) is decorated with
-all its (active) rules.  No need to construct a rule base or anything
-like that.
-

 \begin{code}
 \begin{code}

-ruleCheckProgram :: CompilerPhase -> String -> [CoreBind] -> SDoc
--- Report partial matches for rules beginning 
--- with the specified string
-ruleCheckProgram phase rule_pat binds 
+-- | Report partial matches for rules beginning with the specified
+-- string for the purposes of error reporting
+ruleCheckProgram :: (Activation -> Bool)    -- ^ Rule activation test
+                 -> String                      -- ^ Rule pattern
+                 -> RuleBase                    -- ^ Database of rules
+                 -> [CoreBind]                  -- ^ Bindings to check in
+                 -> SDoc                        -- ^ Resulting check message
+ruleCheckProgram is_active 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

@@ -754,10 +821,14 @@ ruleCheckProgram phase rule_pat binds
          vcat [ p $$ line | p <- bagToList results ]
         ]
   where
          vcat [ p $$ line | p <- bagToList results ]
         ]
   where

-    results = unionManyBags (map (ruleCheckBind (phase, rule_pat)) binds)
+    results = unionManyBags (map (ruleCheckBind (RuleCheckEnv is_active rule_pat rule_base)) binds)

     line = text (replicate 20 '-')
          
     line = text (replicate 20 '-')
          

-type RuleCheckEnv = (CompilerPhase, String)    -- Phase and Pattern
+data RuleCheckEnv = RuleCheckEnv {
+    rc_is_active :: Activation -> Bool, 
+    rc_pattern :: String, 
+    rc_rule_base :: RuleBase
+}

 
 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
    -- The Bag returned has one SDoc for each call site found
 
 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
    -- The Bag returned has one SDoc for each call site found

@@ -786,15 +857,15 @@ ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
 -- Produce a report for all rules matching the predicate
 -- saying why it doesn't match the specified application
 
 -- Produce a report for all rules matching the predicate
 -- saying why it doesn't match the specified application
 

-ruleCheckFun (phase, pat) fn args
+ruleCheckFun env fn args

   | null name_match_rules = emptyBag
   | null name_match_rules = emptyBag

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

   where
   where

-    name_match_rules = filter match (idCoreRules fn)
-    match rule = pat `isPrefixOf` unpackFS (ruleName rule)
+    name_match_rules = filter match (getRules (rc_rule_base env) fn)
+    match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule)

 
 

-ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
-ruleAppCheck_help phase fn args rules
+ruleAppCheck_help :: (Activation -> Bool) -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
+ruleAppCheck_help is_active 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)]

@@ -806,9 +877,9 @@ ruleAppCheck_help phase fn args rules
     check_rule rule = rule_herald rule <> colon <+> rule_info rule
 
     rule_herald (BuiltinRule { ru_name = name })
     check_rule rule = rule_herald rule <> colon <+> rule_info rule
 
     rule_herald (BuiltinRule { ru_name = name })

-       = ptext SLIT("Builtin rule") <+> doubleQuotes (ftext name)
+       = ptext (sLit "Builtin rule") <+> doubleQuotes (ftext name)

     rule_herald (Rule { ru_name = name })
     rule_herald (Rule { ru_name = name })

-       = ptext SLIT("Rule") <+> doubleQuotes (ftext name)
+       = ptext (sLit "Rule") <+> doubleQuotes (ftext name)

 
     rule_info rule
        | Just _ <- matchRule noBlackList emptyInScopeSet args rough_args rule
 
     rule_info rule
        | Just _ <- matchRule noBlackList emptyInScopeSet args rough_args rule

@@ -818,7 +889,7 @@ ruleAppCheck_help phase fn args rules
 
     rule_info (Rule { ru_name = name, ru_act = act, 
                      ru_bndrs = rule_bndrs, ru_args = rule_args})
 
     rule_info (Rule { ru_name = name, ru_act = act, 
                      ru_bndrs = rule_bndrs, ru_args = rule_args})

-       | not (isActive phase act)    = text "active only in later phase"
+       | not (is_active 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"