Add GHC-API logging hooks

* Add 'dumpAction' hook to DynFlags.

It allows GHC API users to catch dumped intermediate codes and
information. The format of the dump (Core, Stg, raw text, etc.) is now
reported allowing easier automatic handling.

* Add 'traceAction' hook to DynFlags.

Some dumps go through the trace mechanism (for instance unfoldings that
have been considered for inlining). This is problematic because:
1) dumps aren't written into files even with -ddump-to-file on
2) dumps are written on stdout even with GHC API
3) in this specific case, dumping depends on unsafe globally stored
DynFlags which is bad for GHC API users

We introduce 'traceAction' hook which allows GHC API to catch those
traces and to avoid using globally stored DynFlags.

* Avoid dumping empty logs via dumpAction/traceAction (but still write
empty files to keep the existing behavior)

1 files changed, 15 insertions, 5 deletions

diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
index 7d830d0337..556c943dc2 100644
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -359,6 +359,7 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
           let platform = targetPlatform dflags
           dumpIfSet_dyn dflags
                   Opt_D_dump_asm_conflicts "Register conflict graph"
+                  FormatText
                   $ Color.dotGraph
                           (targetRegDotColor platform)
                           (Color.trivColorable platform
@@ -377,7 +378,9 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
                 $ makeImportsDoc dflags (concat (ngs_imports ngs))
         return us'
   where
-    dump_stats = dumpSDoc dflags alwaysQualify Opt_D_dump_asm_stats "NCG stats"
+    dump_stats = dumpAction dflags (mkDumpStyle dflags alwaysQualify)
+                   (dumpOptionsFromFlag Opt_D_dump_asm_stats) "NCG stats"
+                   FormatText
 
 cmmNativeGenStream :: (Outputable statics, Outputable instr
                       ,Outputable jumpDest, Instruction instr)
@@ -420,7 +423,7 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
               -- See Note [What is this unwinding business?] in Debug.
               let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs
               unless (null ldbgs) $
-                dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"
+                dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos" FormatText
                   (vcat $ map ppr ldbgs)
 
               -- Accumulate debug information for emission in finishNativeGen.
@@ -505,7 +508,7 @@ emitNativeCode dflags h sdoc = do
 
         -- dump native code
         dumpIfSet_dyn dflags
-                Opt_D_dump_asm "Asm code"
+                Opt_D_dump_asm "Asm code" FormatASM
                 sdoc
 
 -- | Complete native code generation phase for a single top-level chunk of Cmm.
@@ -550,7 +553,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
                 cmmToCmm dflags this_mod fixed_cmm
 
         dumpIfSet_dyn dflags
-                Opt_D_dump_opt_cmm "Optimised Cmm"
+                Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM
                 (pprCmmGroup [opt_cmm])
 
         let cmmCfg = {-# SCC "getCFG" #-}
@@ -564,7 +567,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
                                         fileIds dbgMap opt_cmm cmmCfg
 
         dumpIfSet_dyn dflags
-                Opt_D_dump_asm_native "Native code"
+                Opt_D_dump_asm_native "Native code" FormatASM
                 (vcat $ map (pprNatCmmDecl ncgImpl) native)
 
         maybeDumpCfg dflags (Just nativeCfgWeights) "CFG Weights - Native" proc_name
@@ -582,6 +585,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
 
         dumpIfSet_dyn dflags
                 Opt_D_dump_asm_liveness "Liveness annotations added"
+                FormatCMM
                 (vcat $ map ppr withLiveness)
 
         -- allocate registers
@@ -621,10 +625,12 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
                 -- dump out what happened during register allocation
                 dumpIfSet_dyn dflags
                         Opt_D_dump_asm_regalloc "Registers allocated"
+                        FormatCMM
                         (vcat $ map (pprNatCmmDecl ncgImpl) alloced)
 
                 dumpIfSet_dyn dflags
                         Opt_D_dump_asm_regalloc_stages "Build/spill stages"
+                        FormatText
                         (vcat   $ map (\(stage, stats)
                                         -> text "# --------------------------"
                                         $$ text "#  cmm " <> int count <> text " Stage " <> int stage
@@ -663,6 +669,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
 
                 dumpIfSet_dyn dflags
                         Opt_D_dump_asm_regalloc "Registers allocated"
+                        FormatCMM
                         (vcat $ map (pprNatCmmDecl ncgImpl) alloced)
 
                 let mPprStats =
@@ -697,6 +704,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
 
         when (not $ null nativeCfgWeights) $ dumpIfSet_dyn dflags
                 Opt_D_dump_cfg_weights "CFG Update information"
+                FormatText
                 ( text "stack:" <+> ppr stack_updt_blks $$
                   text "linearAlloc:" <+> ppr cfgRegAllocUpdates )
 
@@ -753,6 +761,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
 
         dumpIfSet_dyn dflags
                 Opt_D_dump_asm_expanded "Synthetic instructions expanded"
+                FormatCMM
                 (vcat $ map (pprNatCmmDecl ncgImpl) expanded)
 
         -- generate unwinding information from cmm
@@ -779,6 +788,7 @@ maybeDumpCfg dflags (Just cfg) msg proc_name
         | otherwise
         = dumpIfSet_dyn
                 dflags Opt_D_dump_cfg_weights msg
+                FormatText
                 (proc_name <> char ':' $$ pprEdgeWeights cfg)
 
 -- | Make sure all blocks we want the layout algorithm to place have been placed.