From e934294fd6c4a3beb150b5a6c03299d8c42fd306 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Fri, 18 Dec 2009 16:37:42 +0000
Subject: [PATCH] Make -ddump-inlinings and -ddump-rule-firings less noisy

By default, these two now print *one line* per inlining or rule-firing.

If you want the previous (voluminous) behaviour, use -dverbose-core2core.
---
 compiler/coreSyn/CoreUnfold.lhs |    2 +-
 compiler/simplCore/Simplify.lhs |   48 ++++++++++++++++++++++++---------------
 2 files changed, 31 insertions(+), 19 deletions(-)

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index f8043d4..bcd03b2 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -741,7 +741,7 @@ callSiteInline dflags id unfolding lone_variable arg_infos cont_info
 				              res_discount arg_infos cont_info
 		
     in    
-    if dopt Opt_D_dump_inlinings dflags then
+    if (dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags) then
 	pprTrace ("Considering inlining: " ++ showSDoc (ppr id))
 		 (vcat [text "arg infos" <+> ppr arg_infos,
 			text "uf arity" <+> ppr uf_arity,
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index b7084c8..60ee802 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -213,8 +213,7 @@ simplTopBinds env0 binds0
                 -- It's rather as if the top-level binders were imported.
         ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0)
         ; dflags <- getDOptsSmpl
-        ; let dump_flag = dopt Opt_D_dump_inlinings dflags ||
-                          dopt Opt_D_dump_rule_firings dflags
+        ; let dump_flag = dopt Opt_D_verbose_core2core dflags
         ; env2 <- simpl_binds dump_flag env1 binds0
         ; freeTick SimplifierDone
         ; return env2 }
@@ -1133,13 +1132,7 @@ completeCall env var cont
         ; case maybe_inline of {
             Just unfolding      -- There is an inlining!
               ->  do { tick (UnfoldingDone var)
-                     ; (if dopt Opt_D_dump_inlinings dflags then
-                           pprTrace ("Inlining done: " ++ showSDoc (ppr var)) (vcat [
-                                text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
-                                text "Inlined fn: " <+> nest 2 (ppr unfolding),
-                                text "Cont:  " <+> ppr call_cont])
-                         else
-                                id)
+                     ; trace_inline dflags unfolding args call_cont $
                        simplExprF (zapSubstEnv env) unfolding cont }
 
             ; Nothing -> do               -- No inlining!
@@ -1148,6 +1141,19 @@ completeCall env var cont
         ; let info = mkArgInfo var (getRules rule_base var) n_val_args call_cont
         ; rebuildCall env info cont
     }}}
+  where
+    trace_inline dflags unfolding args call_cont stuff
+      | not (dopt Opt_D_dump_inlinings dflags) = stuff
+      | not (dopt Opt_D_verbose_core2core dflags) 
+      = if isExternalName (idName var) then 
+      	  pprTrace "Inlining done:" (ppr var) stuff
+        else stuff
+      | otherwise
+      = pprTrace ("Inlining done: " ++ showSDoc (ppr var))
+           (vcat [text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
+                  text "Inlined fn: " <+> nest 2 (ppr unfolding),
+                  text "Cont:  " <+> ppr call_cont])
+           stuff
 
 rebuildCall :: SimplEnv
             -> ArgInfo
@@ -1277,15 +1283,21 @@ tryRules env rules fn args call_cont
            Just (rule, rule_rhs) ->
 
              do { tick (RuleFired (ru_name rule))
-                ; (if dopt Opt_D_dump_rule_firings dflags then
-                     pprTrace "Rule fired" (vcat [
-                        text "Rule:" <+> ftext (ru_name rule),
-                        text "Before:" <+> ppr fn <+> sep (map pprParendExpr args),
-                        text "After: " <+> pprCoreExpr rule_rhs,
-                        text "Cont:  " <+> ppr call_cont])
-                   else
-                        id)             $
-                   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) = stuff
+      | not (dopt Opt_D_verbose_core2core dflags) 
+
+      = pprTrace "Rule fired:" (ftext (ru_name rule)) stuff
+      | otherwise
+      = pprTrace "Rule fired"
+           (vcat [text "Rule:" <+> ftext (ru_name rule),
+           	  text "Before:" <+> ppr fn <+> sep (map pprParendExpr args),
+           	  text "After: " <+> pprCoreExpr rule_rhs,
+           	  text "Cont:  " <+> ppr call_cont])
+           stuff
 \end{code}
 
 Note [Rules for recursive functions]
-- 
1.7.10.4