Fix the -frule-check pass

Rules for imported things are now kept in the global rule base, not
attached to the global Id.  The rule-check pass hadn't kept up.

This should fix it.

diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 844c401..c7b2e69 100644 (file)
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -157,7 +157,7 @@ doCorePass CoreDoSpecConstr        = {-# SCC "SpecConstr" #-}    trBindsU specCo
 doCorePass CoreDoGlomBinds            = trBinds glomBinds
 doCorePass CoreDoVectorisation         = {-# SCC "Vectorise" #-}     vectorise
 doCorePass CoreDoPrintCore            = observe printCore
 doCorePass CoreDoGlomBinds            = trBinds glomBinds
 doCorePass CoreDoVectorisation         = {-# SCC "Vectorise" #-}     vectorise
 doCorePass CoreDoPrintCore            = observe printCore

-doCorePass (CoreDoRuleCheck phase pat) = observe (ruleCheck phase pat)
+doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat

 doCorePass CoreDoNothing              = observe (\ _ _ -> return ())
 #ifdef OLD_STRICTNESS                 
 doCorePass CoreDoOldStrictness        = {-# SCC "OldStrictness" #-} trBinds doOldStrictness
 doCorePass CoreDoNothing              = observe (\ _ _ -> return ())
 #ifdef OLD_STRICTNESS                 
 doCorePass CoreDoOldStrictness        = {-# SCC "OldStrictness" #-} trBinds doOldStrictness

@@ -175,8 +175,11 @@ doOldStrictness dfs binds
 
 printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
 
 
 printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
 

-ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck"
-                                     printDump (ruleCheckProgram phase pat binds)
+ruleCheck phase pat hsc_env us rb guts 
+  =  do let dflags = hsc_dflags hsc_env
+       showPass dflags "RuleCheck"
+        printDump (ruleCheckProgram phase pat rb (mg_binds guts))
+       return (zeroSimplCount dflags, guts)

 
 -- Most passes return no stats and don't change rules
 trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
 
 -- Most passes return no stats and don't change rules
 trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])

diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 24c4004..bbb678d 100644 (file)
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -225,15 +225,17 @@ lookupRule :: (Activation -> Bool) -> InScopeSet
           -> Id -> [CoreExpr] -> Maybe (CoreRule, CoreExpr)
 -- See Note [Extra argsin rule matching]
 lookupRule is_active in_scope rule_base fn args
           -> Id -> [CoreExpr] -> Maybe (CoreRule, CoreExpr)
 -- See Note [Extra argsin rule matching]
 lookupRule is_active in_scope rule_base fn args

-  = matchRules is_active in_scope fn args rules
-  where
+  = matchRules is_active in_scope fn args (getRules rule_base fn)
+
+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)
        -- 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` []
+getRules rule_base fn
+  | isLocalId fn = idCoreRules fn
+  | otherwise    = WARN( null (idCoreRules fn), ppr fn <+> ppr (idCoreRules fn) )
+                  lookupNameEnv rule_base (idName fn) `orElse` []

 
 matchRules :: (Activation -> Bool) -> InScopeSet
           -> Id -> [CoreExpr]
 
 matchRules :: (Activation -> Bool) -> InScopeSet
           -> Id -> [CoreExpr]

@@ -765,16 +767,11 @@ 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
+ruleCheckProgram :: CompilerPhase -> String -> RuleBase -> [CoreBind] -> SDoc

 -- Report partial matches for rules beginning 
 -- with the specified string
 -- Report partial matches for rules beginning 
 -- with the specified string

-ruleCheckProgram phase rule_pat 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

@@ -783,10 +780,10 @@ 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 (phase, rule_pat, rule_base)) binds)

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

-type RuleCheckEnv = (CompilerPhase, String)    -- Phase and Pattern
+type RuleCheckEnv = (CompilerPhase, String, RuleBase)  -- Phase and Pattern

 
 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

@@ -815,11 +812,11 @@ 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 (phase, pat, rule_base) fn args

   | null name_match_rules = emptyBag
   | otherwise            = unitBag (ruleAppCheck_help phase fn args name_match_rules)
   where
   | null name_match_rules = emptyBag
   | otherwise            = unitBag (ruleAppCheck_help phase fn args name_match_rules)
   where

-    name_match_rules = filter match (idCoreRules fn)
+    name_match_rules = filter match (getRules rule_base fn)

     match rule = pat `isPrefixOf` unpackFS (ruleName rule)
 
 ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
     match rule = pat `isPrefixOf` unpackFS (ruleName rule)
 
 ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc