Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/3fcf5bdff7a22e22d7265535369cd8f867141ec1 >--------------------------------------------------------------- commit 3fcf5bdff7a22e22d7265535369cd8f867141ec1 Author: Paolo Capriotti <[email protected]> Date: Thu Jul 12 17:53:50 2012 +0100 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. >--------------------------------------------------------------- compiler/main/TidyPgm.lhs | 10 +++++----- compiler/simplCore/Simplify.lhs | 34 +++++++++++++++++++--------------- 2 files changed, 24 insertions(+), 20 deletions(-) diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 8e4e7dd..85127e6 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -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 diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 115dd94..df9013c 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -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] _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
