Commit 3d378d98 authored by Matthew Pickering's avatar Matthew Pickering Committed by Ben Gamari
Browse files

Also check local rules with -frules-check

Reviewers: bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie, carter

Differential Revision: https://phabricator.haskell.org/D4255
parent 2918abf7
...@@ -17,7 +17,8 @@ import CoreSyn ...@@ -17,7 +17,8 @@ import CoreSyn
import HscTypes import HscTypes
import CSE ( cseProgram ) import CSE ( cseProgram )
import Rules ( mkRuleBase, unionRuleBase, import Rules ( mkRuleBase, unionRuleBase,
extendRuleBaseList, ruleCheckProgram, addRuleInfo, ) extendRuleBaseList, ruleCheckProgram, addRuleInfo,
getRules )
import PprCore ( pprCoreBindings, pprCoreExpr ) import PprCore ( pprCoreBindings, pprCoreExpr )
import OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
import IdInfo import IdInfo
...@@ -516,10 +517,12 @@ ruleCheckPass current_phase pat guts = ...@@ -516,10 +517,12 @@ ruleCheckPass current_phase pat guts =
{ rb <- getRuleBase { rb <- getRuleBase
; dflags <- getDynFlags ; dflags <- getDynFlags
; vis_orphs <- getVisibleOrphanMods ; vis_orphs <- getVisibleOrphanMods
; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn
++ (mg_rules guts)
; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan
(defaultDumpStyle dflags) (defaultDumpStyle dflags)
(ruleCheckProgram current_phase pat (ruleCheckProgram current_phase pat
(RuleEnv rb vis_orphs) (mg_binds guts)) rule_fn (mg_binds guts))
; return guts } ; return guts }
doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
......
...@@ -1148,10 +1148,10 @@ is so important. ...@@ -1148,10 +1148,10 @@ is so important.
-- string for the purposes of error reporting -- string for the purposes of error reporting
ruleCheckProgram :: CompilerPhase -- ^ Rule activation test ruleCheckProgram :: CompilerPhase -- ^ Rule activation test
-> String -- ^ Rule pattern -> String -- ^ Rule pattern
-> RuleEnv -- ^ Database of rules -> (Id -> [CoreRule]) -- ^ Rules for an Id
-> CoreProgram -- ^ Bindings to check in -> CoreProgram -- ^ Bindings to check in
-> SDoc -- ^ Resulting check message -> SDoc -- ^ Resulting check message
ruleCheckProgram phase rule_pat rule_base binds ruleCheckProgram phase rule_pat rules binds
| isEmptyBag results | isEmptyBag results
= text "Rule check results: no rule application sites" = text "Rule check results: no rule application sites"
| otherwise | otherwise
...@@ -1164,7 +1164,7 @@ ruleCheckProgram phase rule_pat rule_base binds ...@@ -1164,7 +1164,7 @@ ruleCheckProgram phase rule_pat rule_base binds
, rc_id_unf = idUnfolding -- Not quite right , rc_id_unf = idUnfolding -- Not quite right
-- Should use activeUnfolding -- Should use activeUnfolding
, rc_pattern = rule_pat , rc_pattern = rule_pat
, rc_rule_base = rule_base } , rc_rules = rules }
results = unionManyBags (map (ruleCheckBind env) binds) results = unionManyBags (map (ruleCheckBind env) binds)
line = text (replicate 20 '-') line = text (replicate 20 '-')
...@@ -1172,7 +1172,7 @@ data RuleCheckEnv = RuleCheckEnv { ...@@ -1172,7 +1172,7 @@ data RuleCheckEnv = RuleCheckEnv {
rc_is_active :: Activation -> Bool, rc_is_active :: Activation -> Bool,
rc_id_unf :: IdUnfoldingFun, rc_id_unf :: IdUnfoldingFun,
rc_pattern :: String, rc_pattern :: String,
rc_rule_base :: RuleEnv rc_rules :: Id -> [CoreRule]
} }
ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
...@@ -1206,7 +1206,7 @@ ruleCheckFun env fn args ...@@ -1206,7 +1206,7 @@ ruleCheckFun env fn args
| null name_match_rules = emptyBag | null name_match_rules = emptyBag
| otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules)
where where
name_match_rules = filter match (getRules (rc_rule_base env) fn) name_match_rules = filter match (rc_rules env fn)
match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule) match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule)
ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment