New flag -dddump-rule-rewrites

Now, -ddump-rule-firings only shows the names of the rules that fired (it would
show "before" and "after" with -dverbose-core2core previously) and
-ddump-rule-rewrites always shows the "before" and "after" bits, even without
-dverbose-core2core.

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 4c52d2a..7a4607a 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -133,6 +133,7 @@ data DynFlag
    | Opt_D_dump_foreign
    | Opt_D_dump_inlinings
    | Opt_D_dump_rule_firings
+   | Opt_D_dump_rule_rewrites
    | Opt_D_dump_occur_anal
    | Opt_D_dump_parsed
    | Opt_D_dump_rn
@@ -1232,6 +1233,7 @@ dynamic_flags = [
   , Flag "ddump-foreign"           (setDumpFlag Opt_D_dump_foreign)
   , Flag "ddump-inlinings"         (setDumpFlag Opt_D_dump_inlinings)
   , Flag "ddump-rule-firings"      (setDumpFlag Opt_D_dump_rule_firings)
+  , Flag "ddump-rule-rewrites"     (setDumpFlag Opt_D_dump_rule_rewrites)
   , Flag "ddump-occur-anal"        (setDumpFlag Opt_D_dump_occur_anal)
   , Flag "ddump-parsed"            (setDumpFlag Opt_D_dump_parsed)
   , Flag "ddump-rn"                (setDumpFlag Opt_D_dump_rn)

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index df80c4a..7894d7e 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1363,14 +1363,15 @@ tryRules env rules fn args call_cont
                   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) 
+      | 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)
 
       = 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 "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)),
                  text "After: " <+> pprCoreExpr rule_rhs,
                  text "Cont:  " <+> ppr call_cont])
            stuff