CodeGen: Way to dump cmm only once (#11717)

The `-ddump-cmm` put all stages of Cmm processing into one output.
This patch changes its behavior and adds two more options to make
Cmm dumping flexible.

- `-ddump-cmm-from-stg` dumps only initial version of  Cmm right after
   STG->Cmm codegen
- `-ddump-cmm` dumps the final result of the Cmm pipeline processing
- `-ddump-cmm-verbose` dumps intermediate output of each Cmm pipeline
   step
- `-ddump-cmm-proc` and `-ddump-cmm-caf` seems were lost. Now enabled

Test Plan: ./validate

Reviewers: thomie, simonmar, austin, bgamari

Reviewed By: thomie, simonmar

Subscribers: simonpj, thomie

Differential Revision: https://phabricator.haskell.org/D2393

GHC Trac Issues: #11717

4 files changed, 38 insertions, 28 deletions

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index e07e0a65c8..6b326b8bfb 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -1394,9 +1394,7 @@ parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brack
         let ms = getMessages pst dflags
         if (errorsFound dflags ms)
          then return (ms, Nothing)
-         else do
-           dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm)
-           return (ms, Just cmm)
+         else return (ms, Just cmm)
   where
         no_module = panic "parseCmmFile: no module"
 }
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index 37dbd12525..b19e4180f8 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -31,7 +31,7 @@ import Platform
 -----------------------------------------------------------------------------
 
 cmmPipeline  :: HscEnv -- Compilation env including
-                       -- dynamic flags: -dcmm-lint -ddump-cps-cmm
+                       -- dynamic flags: -dcmm-lint -ddump-cmm-cps
              -> TopSRT     -- SRT table and accumulating list of compiled procs
              -> CmmGroup             -- Input C-- with Procedures
              -> IO (TopSRT, CmmGroup) -- Output CPS transformed C--
@@ -42,7 +42,7 @@ cmmPipeline hsc_env topSRT prog =
      tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
 
      (topSRT, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags topSRT tops
-     dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" cmms
+     dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" (ppr cmms)
 
      return (topSRT, cmms)
 
@@ -83,7 +83,7 @@ cpsTop hsc_env proc =
              then do
                pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
                   minimalProcPointSet (targetPlatform dflags) call_pps g
-               dumpIfSet_dyn dflags Opt_D_dump_cmm "Proc points"
+               dumpWith dflags Opt_D_dump_cmm_proc "Proc points"
                      (ppr l $$ ppr pp $$ ppr g)
                return pp
              else
@@ -104,14 +104,15 @@ cpsTop hsc_env proc =
 
        ------------- CAF analysis ----------------------------------------------
        let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
-       dumpIfSet_dyn dflags Opt_D_dump_cmm "CAFEnv" (ppr cafEnv)
+       dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" (ppr cafEnv)
 
        g <- if splitting_proc_points
             then do
                ------------- Split into separate procedures -----------------------
                pp_map  <- {-# SCC "procPointAnalysis" #-} runUniqSM $
                           procPointAnalysis proc_points g
-               dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" pp_map
+               dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" $
+                    ppr pp_map
                g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
                     splitAtProcPoints dflags l call_pps proc_points pp_map
                                       (CmmProc h l v g)
@@ -142,7 +143,7 @@ cpsTop hsc_env proc =
         dump = dumpGraph dflags
 
         dumps flag name
-           = mapM_ (dumpWith dflags flag name)
+           = mapM_ (dumpWith dflags flag name . ppr)
 
         condPass flag pass g dumpflag dumpname =
             if gopt flag dflags
@@ -346,7 +347,7 @@ runUniqSM m = do
 dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
 dumpGraph dflags flag name g = do
   when (gopt Opt_DoCmmLinting dflags) $ do_lint g
-  dumpWith dflags flag name g
+  dumpWith dflags flag name (ppr g)
  where
   do_lint g = case cmmLintGraph dflags g of
                  Just err -> do { fatalErrorMsg dflags err
@@ -354,11 +355,11 @@ dumpGraph dflags flag name g = do
                                 }
                  Nothing  -> return ()
 
-dumpWith :: Outputable a => DynFlags -> DumpFlag -> String -> a -> IO ()
-dumpWith dflags flag txt g = do
+dumpWith :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
+dumpWith dflags flag txt sdoc = do
          -- ToDo: No easy way of say "dump all the cmm, *and* split
-         -- them into files."  Also, -ddump-cmm doesn't play nicely
-         -- with -ddump-to-file, since the headers get omitted.
-   dumpIfSet_dyn dflags flag txt (ppr g)
+         -- them into files."  Also, -ddump-cmm-verbose doesn't play
+         -- nicely with -ddump-to-file, since the headers get omitted.
+   dumpIfSet_dyn dflags flag txt sdoc
    when (not (dopt flag dflags)) $
-      dumpIfSet_dyn dflags Opt_D_dump_cmm txt (ppr g)
+      dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose txt sdoc
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 24746d6836..dc29176ddf 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -295,15 +295,19 @@ data DumpFlag
 
    -- debugging flags
    = Opt_D_dump_cmm
+   | Opt_D_dump_cmm_from_stg
    | Opt_D_dump_cmm_raw
-   -- All of the cmm subflags (there are a lot!)  Automatically
-   -- enabled if you run -ddump-cmm
+   | Opt_D_dump_cmm_verbose
+   -- All of the cmm subflags (there are a lot!) automatically
+   -- enabled if you run -ddump-cmm-verbose
+   -- Each flag corresponds to exact stage of Cmm pipeline.
    | Opt_D_dump_cmm_cfg
    | Opt_D_dump_cmm_cbe
    | Opt_D_dump_cmm_switch
    | Opt_D_dump_cmm_proc
-   | Opt_D_dump_cmm_sink
    | Opt_D_dump_cmm_sp
+   | Opt_D_dump_cmm_sink
+   | Opt_D_dump_cmm_caf
    | Opt_D_dump_cmm_procmap
    | Opt_D_dump_cmm_split
    | Opt_D_dump_cmm_info
@@ -2606,8 +2610,12 @@ dynamic_flags_deps = [
 
   , make_ord_flag defGhcFlag "ddump-cmm"
         (setDumpFlag Opt_D_dump_cmm)
+  , make_ord_flag defGhcFlag "ddump-cmm-from-stg"
+        (setDumpFlag Opt_D_dump_cmm_from_stg)
   , make_ord_flag defGhcFlag "ddump-cmm-raw"
         (setDumpFlag Opt_D_dump_cmm_raw)
+  , make_ord_flag defGhcFlag "ddump-cmm-verbose"
+        (setDumpFlag Opt_D_dump_cmm_verbose)
   , make_ord_flag defGhcFlag "ddump-cmm-cfg"
         (setDumpFlag Opt_D_dump_cmm_cfg)
   , make_ord_flag defGhcFlag "ddump-cmm-cbe"
@@ -2616,10 +2624,12 @@ dynamic_flags_deps = [
         (setDumpFlag Opt_D_dump_cmm_switch)
   , make_ord_flag defGhcFlag "ddump-cmm-proc"
         (setDumpFlag Opt_D_dump_cmm_proc)
-  , make_ord_flag defGhcFlag "ddump-cmm-sink"
-        (setDumpFlag Opt_D_dump_cmm_sink)
   , make_ord_flag defGhcFlag "ddump-cmm-sp"
         (setDumpFlag Opt_D_dump_cmm_sp)
+  , make_ord_flag defGhcFlag "ddump-cmm-sink"
+        (setDumpFlag Opt_D_dump_cmm_sink)
+  , make_ord_flag defGhcFlag "ddump-cmm-caf"
+        (setDumpFlag Opt_D_dump_cmm_caf)
   , make_ord_flag defGhcFlag "ddump-cmm-procmap"
         (setDumpFlag Opt_D_dump_cmm_procmap)
   , make_ord_flag defGhcFlag "ddump-cmm-split"
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 9c510df27b..bd7f8c9cde 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -1337,16 +1337,16 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
     liftIO $ do
         us <- mkSplitUniqSupply 'S'
         let initTopSRT = initUs_ us emptySRT
-        dumpIfSet_dyn dflags Opt_D_dump_cmm "Parsed Cmm" (ppr cmm)
+        dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose "Parsed Cmm" (ppr cmm)
         (_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm
         rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)
         _ <- codeOutput dflags no_mod output_filename no_loc NoStubs [] rawCmms
         return ()
   where
-    no_mod = panic "hscCmmFile: no_mod"
+    no_mod = panic "hscCompileCmmFile: no_mod"
     no_loc = ModLocation{ ml_hs_file  = Just filename,
-                          ml_hi_file  = panic "hscCmmFile: no hi file",
-                          ml_obj_file = panic "hscCmmFile: no obj file" }
+                          ml_hi_file  = panic "hscCompileCmmFile: no hi file",
+                          ml_obj_file = panic "hscCompileCmmFile: no obj file" }
 
 -------------------- Stuff for new code gen ---------------------
 
@@ -1372,8 +1372,8 @@ doCodeGen hsc_env this_mod data_tycons
         -- CmmGroup on input may produce many CmmGroups on output due
         -- to proc-point splitting).
 
-    let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm
-                       "Cmm produced by new codegen" (ppr a)
+    let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg
+                       "Cmm produced by codegen" (ppr a)
                      return a
 
         ppr_stream1 = Stream.mapM dump1 cmm_stream
@@ -1406,7 +1406,8 @@ doCodeGen hsc_env this_mod data_tycons
                 Stream.yield (srtToData topSRT)
 
     let
-        dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" $ ppr a
+        dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm
+                        "Output Cmm" (ppr a)
                      return a
 
         ppr_stream2 = Stream.mapM dump2 pipeline_stream