diff options
| -rw-r--r-- | compiler/main/ErrUtils.lhs | 7 | ||||
| -rw-r--r-- | compiler/simplCore/Simplify.lhs | 19 |
2 files changed, 15 insertions, 11 deletions
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index daa66f9d2f..84722aa74a 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -251,8 +251,11 @@ dumpSDoc dflags dflag hdr doc hClose handle -- write the dump to stdout - Nothing - -> log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc) + Nothing -> do + let (doc', severity) + | null hdr = (doc, SevOutput) + | otherwise = (mkDumpDoc hdr doc, SevDump) + log_action dflags dflags severity noSrcSpan defaultDumpStyle doc' -- | Choose where to put a dump file based on DynFlags diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index df9013cd08..f2ed224df4 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -1571,21 +1571,22 @@ tryRules env rules fn args call_cont where 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] + = log_rule dflags Opt_D_dump_rule_rewrites "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 ] | dopt Opt_D_dump_rule_firings dflags - = liftIO . dumpSDoc dflags Opt_D_dump_rule_firings "" $ - vcat [text "Rule fired", - ftext (ru_name rule)] + = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $ + ftext (ru_name rule) | otherwise = return () + log_rule dflags dflag hdr details = liftIO . dumpSDoc dflags dflag "" $ + sep [text hdr, nest 4 details] + \end{code} Note [Rules for recursive functions] |