diff options
| author | Matthew Pickering <matthewtpickering@gmail.com> | 2018-03-19 11:57:06 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2018-03-19 12:05:11 -0400 |
| commit | 3d378d983a28d3650220180e1524c63fb2f4c747 (patch) | |
| tree | 10c496615ba0016c05352e95a4d9dfbb2c079465 | |
| parent | 2918abf75594001deed51ee252a05b146f844489 (diff) | |
| download | haskell-3d378d983a28d3650220180e1524c63fb2f4c747.tar.gz | |
Also check local rules with -frules-check
Reviewers: bgamari
Reviewed By: bgamari
Subscribers: rwbarton, thomie, carter
Differential Revision: https://phabricator.haskell.org/D4255
| -rw-r--r-- | compiler/simplCore/SimplCore.hs | 7 | ||||
| -rw-r--r-- | compiler/specialise/Rules.hs | 10 |
2 files changed, 10 insertions, 7 deletions
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index 0a20eb0d8d..bf69964473 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -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 diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs index 319404ef15..b6025955ac 100644 --- a/compiler/specialise/Rules.hs +++ b/compiler/specialise/Rules.hs @@ -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 |