Commit 3fcf5bdf authored by pcapriotti's avatar pcapriotti

Use dumpSDoc functions to output rules (#7060)

Make -ddump-rules, -ddump-rule-firings and -ddump-rule-rewrites
behave like the other -ddump flags, by using the dumpSDoc function
instance of pprDefiniteTrace.
parent d90176cf
......@@ -54,6 +54,7 @@ import FastBool hiding ( fastOr )
import SrcLoc
import Util
import FastString
import qualified ErrUtils as Err
import Control.Monad
import Data.Function
......@@ -372,11 +373,10 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
-- If the endPass didn't print the rules, but ddump-rules is
-- on, print now
; dumpIfSet dflags (dopt Opt_D_dump_rules dflags
&& (not (dopt Opt_D_dump_simpl dflags)))
CoreTidy
(ptext (sLit "rules"))
(pprRulesForUser tidy_rules)
; unless (dopt Opt_D_dump_simpl dflags) $
Err.dumpIfSet_dyn dflags Opt_D_dump_rules
(showSDoc dflags (ppr CoreTidy <+> ptext (sLit "rules")))
(pprRulesForUser tidy_rules)
-- Print one-line size info
; let cs = coreBindsStats tidy_binds
......
......@@ -43,13 +43,14 @@ import Rules ( lookupRule, getRules )
import BasicTypes ( isMarkedStrict, Arity )
import TysPrim ( realWorldStatePrimTy )
import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
import MonadUtils ( foldlM, mapAccumLM )
import MonadUtils ( foldlM, mapAccumLM, liftIO )
import Maybes ( orElse, isNothing )
import Data.List ( mapAccumL )
import Outputable
import FastString
import Pair
import Util
import ErrUtils
\end{code}
......@@ -1565,23 +1566,26 @@ tryRules env rules fn args call_cont
do { checkedTick (RuleFired (ru_name rule))
; dflags <- getDynFlags
; trace_dump dflags rule rule_rhs $
return (Just (ruleArity rule, rule_rhs)) }}}
; trace_dump dflags rule rule_rhs
; return (Just (ruleArity rule, rule_rhs)) }}}
where
trace_dump dflags rule rule_rhs stuff
| not (dopt Opt_D_dump_rule_firings dflags)
, not (dopt Opt_D_dump_rule_rewrites dflags) = stuff
| not (dopt Opt_D_dump_rule_rewrites dflags)
= pprDefiniteTrace dflags "Rule fired:" (ftext (ru_name rule)) stuff
trace_dump dflags rule rule_rhs
| dopt Opt_D_dump_rule_rewrites dflags
= liftIO . dumpSDoc dflags Opt_D_dump_rule_rewrites "" $
vcat [text "Rule fired",
text "Rule:" <+> ftext (ru_name rule),
text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)),
text "After: " <+> pprCoreExpr rule_rhs,
text "Cont: " <+> ppr call_cont]
| dopt Opt_D_dump_rule_firings dflags
= liftIO . dumpSDoc dflags Opt_D_dump_rule_firings "" $
vcat [text "Rule fired",
ftext (ru_name rule)]
| otherwise
= pprDefiniteTrace dflags "Rule fired"
(vcat [text "Rule:" <+> ftext (ru_name rule),
text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)),
text "After: " <+> pprCoreExpr rule_rhs,
text "Cont: " <+> ppr call_cont])
stuff
= return ()
\end{code}
Note [Rules for recursive functions]
......
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