Create empty dump files when there was nothing to dump

This patch creates empty dump file when GHC was run with
`-ddump-rule-firings` (or `-ddump-rule-rewrites`) and `-ddump-to-file`
specified, and there were no rules applied. If dump already exists it
will be overwritten by empty one.

Test Plan: ./validate

Reviewers: austin, thomie, bgamari

Reviewed By: thomie, bgamari

Subscribers: thomie

Projects: #ghc

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

GHC Trac Issues: #10320

3 files changed, 73 insertions, 31 deletions

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 2e6bac81b8..f2bc57efd5 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -649,8 +649,13 @@ runPipeline' start_phase hsc_env env input_fn
   = do
   -- Execute the pipeline...
   let state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o }
+      dflags = extractDynFlags hsc_env
 
-  evalP (pipeLoop start_phase input_fn) env state
+  -- #10320: Open dump files for writing. Any existing dump specified
+  -- in 'dflags' will be truncated.
+  bracket_ (openDumpFiles dflags)
+           (closeDumpFiles dflags)
+           (evalP (pipeLoop start_phase input_fn) env state)
 
 -- ---------------------------------------------------------------------------
 -- outer pipeline loop
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 77797320a9..4a443f9dbc 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -806,7 +806,7 @@ data DynFlags = DynFlags {
   -- Names of files which were generated from -ddump-to-file; used to
   -- track which ones we need to truncate because it's our first run
   -- through
-  generatedDumps        :: IORef (Set FilePath),
+  generatedDumps        :: IORef (Map FilePath Handle),
 
   -- hsc dynamic flags
   dumpFlags             :: IntSet,
@@ -1386,7 +1386,7 @@ initDynFlags dflags = do
  refFilesToClean <- newIORef []
  refDirsToClean <- newIORef Map.empty
  refFilesToNotIntermediateClean <- newIORef []
- refGeneratedDumps <- newIORef Set.empty
+ refGeneratedDumps <- newIORef Map.empty
  refRtldInfo <- newIORef Nothing
  refRtccInfo <- newIORef Nothing
  wrapperNum <- newIORef emptyModuleEnv
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index efdf808369..9fc9e4902b 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -27,6 +27,8 @@ module ErrUtils (
         dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,
         mkDumpDoc, dumpSDoc,
 
+        openDumpFiles, closeDumpFiles,
+
         --  * Messages during compilation
         putMsg, printInfoForUser, printOutputForUser,
         logInfo, logOutput,
@@ -53,7 +55,7 @@ import System.Directory
 import System.Exit      ( ExitCode(..), exitWith )
 import System.FilePath  ( takeDirectory, (</>) )
 import Data.List
-import qualified Data.Set as Set
+import qualified Data.Map as Map
 import Data.IORef
 import Data.Maybe       ( fromMaybe )
 import Data.Ord
@@ -291,6 +293,15 @@ dumpIfSet_dyn_printer :: PrintUnqualified
 dumpIfSet_dyn_printer printer dflags flag doc
   = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc
 
+-- | a wrapper around 'dumpSDoc'.
+-- First check whether the dump flag is set
+-- Do nothing if it is unset
+--
+-- Makes a dummy write operation into the dump
+dumpIfSet_dyn_empty :: DynFlags -> DumpFlag -> IO ()
+dumpIfSet_dyn_empty dflags flag
+  = when (dopt flag dflags) $ dumpSDoc dflags neverQualify flag "" empty
+
 mkDumpDoc :: String -> SDoc -> SDoc
 mkDumpDoc hdr doc
    = vcat [blankLine,
@@ -300,6 +311,23 @@ mkDumpDoc hdr doc
      where
         line = text (replicate 20 '=')
 
+-- | Open dump files from DynFlags for writing
+--
+-- #10320: This function should be called once before the pipe line
+-- is started. It writes empty data into all requested dumps to initiate
+-- their creation.
+openDumpFiles :: DynFlags -> IO ()
+openDumpFiles dflags
+  = let flags = enumFrom (toEnum 0 :: DumpFlag)
+    in mapM_ (dumpIfSet_dyn_empty dflags) flags
+
+
+-- | Close all opened dump files
+--
+closeDumpFiles :: DynFlags -> IO ()
+closeDumpFiles dflags
+  = do gd <- readIORef $ generatedDumps dflags
+       mapM_ hClose $ Map.elems gd
 
 -- | Write out a dump.
 --      If --dump-to-file is set then this goes to a file.
@@ -315,32 +343,16 @@ dumpSDoc dflags print_unqual flag hdr doc
  = do let mFile = chooseDumpFile dflags flag
           dump_style = mkDumpStyle print_unqual
       case mFile of
-            Just fileName
-                 -> do
-                        let gdref = generatedDumps dflags
-                        gd <- readIORef gdref
-                        let append = Set.member fileName gd
-                            mode = if append then AppendMode else WriteMode
-                        when (not append) $
-                            writeIORef gdref (Set.insert fileName gd)
-                        createDirectoryIfMissing True (takeDirectory fileName)
-                        handle <- openFile fileName mode
-
-                        -- We do not want the dump file to be affected by
-                        -- environment variables, but instead to always use
-                        -- UTF8. See:
-                        -- https://ghc.haskell.org/trac/ghc/ticket/10762
-                        hSetEncoding handle utf8
-
-                        doc' <- if null hdr
-                                then return doc
-                                else do t <- getCurrentTime
-                                        let d = text (show t)
-                                             $$ blankLine
-                                             $$ doc
-                                        return $ mkDumpDoc hdr d
-                        defaultLogActionHPrintDoc dflags handle doc' dump_style
-                        hClose handle
+            Just fileName -> do
+              handle <- getDumpFileHandle dflags fileName
+              doc' <- if null hdr
+                      then return doc
+                      else do t <- getCurrentTime
+                              let d = text (show t)
+                                   $$ blankLine
+                                   $$ doc
+                              return $ mkDumpDoc hdr d
+              defaultLogActionHPrintDoc dflags handle doc' dump_style
 
             -- write the dump to stdout
             Nothing -> do
@@ -349,10 +361,35 @@ dumpSDoc dflags print_unqual flag hdr doc
                     | otherwise = (mkDumpDoc hdr doc, SevDump)
               log_action dflags dflags severity noSrcSpan dump_style doc'
 
+-- | Return a handle assigned to the 'fileName'
+--
+-- If the requested file doesn't exist the new one will be created
+getDumpFileHandle :: DynFlags -> FilePath -> IO Handle
+getDumpFileHandle dflags fileName
+  = do
+      let gdref = generatedDumps dflags
+      gd <- readIORef gdref
+
+      let mHandle = Map.lookup fileName gd
+      case mHandle of
+        Just handle -> return handle
+
+        Nothing -> do
+          createDirectoryIfMissing True (takeDirectory fileName)
+          handle <- openFile fileName WriteMode
+
+          -- We do not want the dump file to be affected by
+          -- environment variables, but instead to always use
+          -- UTF8. See:
+          -- https://ghc.haskell.org/trac/ghc/ticket/10762
+          hSetEncoding handle utf8
+          writeIORef gdref (Map.insert fileName handle gd)
+
+          return handle
 
 -- | Choose where to put a dump file based on DynFlags
 --
-chooseDumpFile :: DynFlags -> DumpFlag -> Maybe String
+chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath
 chooseDumpFile dflags flag
 
         | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file