Commit 04ea4c3f authored by Matthew Pickering's avatar Matthew Pickering Committed by Ben Gamari
Browse files

Print module when dumping rules

It is sometimes hard to find where a rule is defined. Printing the
module where it comes from will make it much easier to find.

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3378
parent 5856c564
...@@ -4,6 +4,7 @@ ...@@ -4,6 +4,7 @@
-} -}
{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts #-} {-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
-- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection -- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection
module CoreSyn ( module CoreSyn (
...@@ -89,7 +90,7 @@ module CoreSyn ( ...@@ -89,7 +90,7 @@ module CoreSyn (
-- ** Operations on 'CoreRule's -- ** Operations on 'CoreRule's
ruleArity, ruleName, ruleIdName, ruleActivation, ruleArity, ruleName, ruleIdName, ruleActivation,
setRuleIdName, setRuleIdName, ruleModule,
isBuiltinRule, isLocalRule, isAutoRule, isBuiltinRule, isLocalRule, isAutoRule,
-- * Core vectorisation declarations data type -- * Core vectorisation declarations data type
...@@ -1246,6 +1247,10 @@ ruleArity (Rule {ru_args = args}) = length args ...@@ -1246,6 +1247,10 @@ ruleArity (Rule {ru_args = args}) = length args
ruleName :: CoreRule -> RuleName ruleName :: CoreRule -> RuleName
ruleName = ru_name ruleName = ru_name
ruleModule :: CoreRule -> Maybe Module
ruleModule Rule { ru_origin } = Just ru_origin
ruleModule BuiltinRule {} = Nothing
ruleActivation :: CoreRule -> Activation ruleActivation :: CoreRule -> Activation
ruleActivation (BuiltinRule { }) = AlwaysActive ruleActivation (BuiltinRule { }) = AlwaysActive
ruleActivation (Rule { ru_act = act }) = act ruleActivation (Rule { ru_act = act }) = act
......
...@@ -51,6 +51,7 @@ import FastString ...@@ -51,6 +51,7 @@ import FastString
import Pair import Pair
import Util import Util
import ErrUtils import ErrUtils
import Module ( moduleName, pprModuleName )
{- {-
The guts of the simplifier is in this module, but the driver loop for The guts of the simplifier is in this module, but the driver loop for
...@@ -1784,7 +1785,7 @@ tryRules env rules fn args call_cont ...@@ -1784,7 +1785,7 @@ tryRules env rules fn args call_cont
do { nodump dflags -- This ensures that an empty file is written do { nodump dflags -- This ensures that an empty file is written
; return Nothing } ; -- No rule matches ; return Nothing } ; -- No rule matches
Just (rule, rule_rhs) -> Just (rule, rule_rhs) ->
do { checkedTick (RuleFired (ru_name rule)) do { checkedTick (RuleFired (ruleName rule))
; let cont' = pushSimplifiedArgs env ; let cont' = pushSimplifiedArgs env
(drop (ruleArity rule) args) (drop (ruleArity rule) args)
call_cont call_cont
...@@ -1796,17 +1797,23 @@ tryRules env rules fn args call_cont ...@@ -1796,17 +1797,23 @@ tryRules env rules fn args call_cont
; dump dflags rule rule_rhs ; dump dflags rule rule_rhs
; return (Just (occ_anald_rhs, cont')) }}} ; return (Just (occ_anald_rhs, cont')) }}}
where where
printRuleModule rule =
parens
(maybe (text "BUILTIN") (pprModuleName . moduleName) (ruleModule rule))
dump dflags rule rule_rhs dump dflags rule rule_rhs
| dopt Opt_D_dump_rule_rewrites dflags | dopt Opt_D_dump_rule_rewrites dflags
= log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat
[ text "Rule:" <+> ftext (ru_name rule) [ text "Rule:" <+> ftext (ruleName rule)
, text "Module:" <+> printRuleModule rule
, text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args)) , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))
, text "After: " <+> pprCoreExpr rule_rhs , text "After: " <+> pprCoreExpr rule_rhs
, text "Cont: " <+> ppr call_cont ] , text "Cont: " <+> ppr call_cont ]
| dopt Opt_D_dump_rule_firings dflags | dopt Opt_D_dump_rule_firings dflags
= log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $ = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $
ftext (ru_name rule) ftext (ruleName rule)
<+> printRuleModule rule
| otherwise | otherwise
= return () = return ()
......
...@@ -263,7 +263,7 @@ pprRulesForUser :: DynFlags -> [CoreRule] -> SDoc ...@@ -263,7 +263,7 @@ pprRulesForUser :: DynFlags -> [CoreRule] -> SDoc
pprRulesForUser dflags rules pprRulesForUser dflags rules
= withPprStyle (defaultUserStyle dflags) $ = withPprStyle (defaultUserStyle dflags) $
pprRules $ pprRules $
sortBy (comparing ru_name) $ sortBy (comparing ruleName) $
tidyRules emptyTidyEnv rules tidyRules emptyTidyEnv rules
{- {-
...@@ -420,7 +420,7 @@ findBest target (rule1,ans1) ((rule2,ans2):prs) ...@@ -420,7 +420,7 @@ findBest target (rule1,ans1) ((rule2,ans2):prs)
| rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs
| debugIsOn = let pp_rule rule = sdocWithPprDebug $ \dbg -> if dbg | debugIsOn = let pp_rule rule = sdocWithPprDebug $ \dbg -> if dbg
then ppr rule then ppr rule
else doubleQuotes (ftext (ru_name rule)) else doubleQuotes (ftext (ruleName rule))
in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"
(vcat [ sdocWithPprDebug $ \dbg -> if dbg (vcat [ sdocWithPprDebug $ \dbg -> if dbg
then text "Expression to match:" <+> ppr fn then text "Expression to match:" <+> ppr fn
......
Rule fired: Class op signum Rule fired: Class op signum (BUILTIN)
Rule fired: Class op abs Rule fired: Class op abs (BUILTIN)
Rule fired: Class op HEq_sc Rule fired: Class op HEq_sc (BUILTIN)
Rule fired: normalize/Double Rule fired: normalize/Double (T7837)
Rule fired: Class op HEq_sc Rule fired: Class op HEq_sc (BUILTIN)
Rule fired: Class op >> Rule fired: Class op >> (BUILTIN)
Rule fired: Class op return Rule fired: Class op return (BUILTIN)
Rule fired: unpack Rule fired: unpack (GHC.Base)
Rule fired: Class op foldr Rule fired: Class op foldr (BUILTIN)
Rule fired: fold/build Rule fired: fold/build (GHC.Base)
Rule fired: <# Rule fired: <# (BUILTIN)
Rule fired: tagToEnum# Rule fired: tagToEnum# (BUILTIN)
Rule fired: unpack-list Rule fired: unpack-list (GHC.Base)
Rule fired: SPEC/T6056 $wsmallerAndRest @ Int Rule fired: SPEC/T6056 $wsmallerAndRest @ Int (T6056)
Rule fired: Class op < Rule fired: Class op < (BUILTIN)
Rule fired: SPEC/T6056 $wsmallerAndRest @ Int Rule fired: SPEC/T6056 $wsmallerAndRest @ Int (T6056)
Rule fired: SPEC/T6056 $wsmallerAndRest @ Int Rule fired: SPEC/T6056 $wsmallerAndRest @ Int (T6056)
Rule fired: SPEC/T6056 $wsmallerAndRest @ Int Rule fired: SPEC/T6056 $wsmallerAndRest @ Int (T6056)
Rule fired: SPEC map2 Rule fired: SPEC map2 (T8848)
Rule fired: SPEC map2 Rule fired: SPEC map2 (T8848)
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