[commit: ghc] master: Print module when dumping rules (04ea4c3)
git at git.haskell.org
git at git.haskell.org
Wed Mar 29 20:53:41 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/04ea4c3f86db4e2cc7b2683f58f2076233039ebf/ghc
>---------------------------------------------------------------
commit 04ea4c3f86db4e2cc7b2683f58f2076233039ebf
Author: Matthew Pickering <matthewtpickering at gmail.com>
Date: Wed Mar 29 16:08:40 2017 -0400
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
>---------------------------------------------------------------
04ea4c3f86db4e2cc7b2683f58f2076233039ebf
compiler/coreSyn/CoreSyn.hs | 7 ++++++-
compiler/simplCore/Simplify.hs | 13 ++++++++++---
compiler/specialise/Rules.hs | 4 ++--
.../tests/indexed-types/should_compile/T7837.stderr | 10 +++++-----
testsuite/tests/perf/compiler/T4007.stdout | 16 ++++++++--------
testsuite/tests/simplCore/should_compile/T6056.stderr | 10 +++++-----
testsuite/tests/simplCore/should_compile/T8848.stdout | 4 ++--
7 files changed, 38 insertions(+), 26 deletions(-)
diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index 6762ed6..bee6289 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -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
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 43006f8..2e814b6 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -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 ()
diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs
index 1dcff82..83b4e8d 100644
--- a/compiler/specialise/Rules.hs
+++ b/compiler/specialise/Rules.hs
@@ -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
diff --git a/testsuite/tests/indexed-types/should_compile/T7837.stderr b/testsuite/tests/indexed-types/should_compile/T7837.stderr
index 7fd0a48..eb68261 100644
--- a/testsuite/tests/indexed-types/should_compile/T7837.stderr
+++ b/testsuite/tests/indexed-types/should_compile/T7837.stderr
@@ -1,5 +1,5 @@
-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)
diff --git a/testsuite/tests/perf/compiler/T4007.stdout b/testsuite/tests/perf/compiler/T4007.stdout
index 59c81d9..7cbc345 100644
--- a/testsuite/tests/perf/compiler/T4007.stdout
+++ b/testsuite/tests/perf/compiler/T4007.stdout
@@ -1,8 +1,8 @@
-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)
diff --git a/testsuite/tests/simplCore/should_compile/T6056.stderr b/testsuite/tests/simplCore/should_compile/T6056.stderr
index 5ef76c0..a1f022e 100644
--- a/testsuite/tests/simplCore/should_compile/T6056.stderr
+++ b/testsuite/tests/simplCore/should_compile/T6056.stderr
@@ -1,5 +1,5 @@
-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)
diff --git a/testsuite/tests/simplCore/should_compile/T8848.stdout b/testsuite/tests/simplCore/should_compile/T8848.stdout
index de0d424..c4a33ad 100644
--- a/testsuite/tests/simplCore/should_compile/T8848.stdout
+++ b/testsuite/tests/simplCore/should_compile/T8848.stdout
@@ -1,2 +1,2 @@
-Rule fired: SPEC map2
-Rule fired: SPEC map2
+Rule fired: SPEC map2 (T8848)
+Rule fired: SPEC map2 (T8848)
More information about the ghc-commits
mailing list