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

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