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

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
import HscTypes
import CSE ( cseProgram )
import Rules ( mkRuleBase, unionRuleBase,
extendRuleBaseList, ruleCheckProgram, addRuleInfo, )
extendRuleBaseList, ruleCheckProgram, addRuleInfo,
getRules )
import PprCore ( pprCoreBindings, pprCoreExpr )
import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
import IdInfo
......@@ -516,10 +517,12 @@ ruleCheckPass current_phase pat guts =
{ rb <- getRuleBase
; dflags <- getDynFlags
; vis_orphs <- getVisibleOrphanMods
; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn
++ (mg_rules guts)
; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan
(defaultDumpStyle dflags)
(ruleCheckProgram current_phase pat
(RuleEnv rb vis_orphs) (mg_binds guts))
rule_fn (mg_binds guts))
; return guts }
doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
......
......@@ -1148,10 +1148,10 @@ is so important.
-- string for the purposes of error reporting
ruleCheckProgram :: CompilerPhase -- ^ Rule activation test
-> String -- ^ Rule pattern
-> RuleEnv -- ^ Database of rules
-> (Id -> [CoreRule]) -- ^ Rules for an Id
-> CoreProgram -- ^ Bindings to check in
-> SDoc -- ^ Resulting check message
ruleCheckProgram phase rule_pat rule_base binds
ruleCheckProgram phase rule_pat rules binds
| isEmptyBag results
= text "Rule check results: no rule application sites"
| otherwise
......@@ -1164,7 +1164,7 @@ ruleCheckProgram phase rule_pat rule_base binds
, rc_id_unf = idUnfolding -- Not quite right
-- Should use activeUnfolding
, rc_pattern = rule_pat
, rc_rule_base = rule_base }
, rc_rules = rules }
results = unionManyBags (map (ruleCheckBind env) binds)
line = text (replicate 20 '-')
......@@ -1172,7 +1172,7 @@ data RuleCheckEnv = RuleCheckEnv {
rc_is_active :: Activation -> Bool,
rc_id_unf :: IdUnfoldingFun,
rc_pattern :: String,
rc_rule_base :: RuleEnv
rc_rules :: Id -> [CoreRule]
}
ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
......@@ -1206,7 +1206,7 @@ ruleCheckFun env fn args
| null name_match_rules = emptyBag
| otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules)
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)
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