Make -ddump-to-file truncate existing files.

Signed-off-by: Edward Z. Yang <ezyang@mit.edu>

2 files changed, 34 insertions, 14 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index d6cb85b941..69185dbaf0 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -108,6 +108,8 @@ import Data.Char
 import Data.List
 import Data.Map (Map)
 import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
 import System.FilePath
 import System.IO        ( stderr, hPutChar )
 
@@ -494,6 +496,11 @@ data DynFlags = DynFlags {
   filesToClean          :: IORef [FilePath],
   dirsToClean           :: IORef (Map FilePath FilePath),
 
+  -- 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),
+
   -- hsc dynamic flags
   flags                 :: [DynFlag],
   -- Don't change this without updating extensionFlags:
@@ -730,12 +737,14 @@ initDynFlags dflags = do
  ways <- readIORef v_Ways
  refFilesToClean <- newIORef []
  refDirsToClean <- newIORef Map.empty
+ refGeneratedDumps <- newIORef Set.empty
  return dflags{
         ways            = ways,
         buildTag        = mkBuildTag (filter (not . wayRTSOnly) ways),
         rtsBuildTag     = mkBuildTag ways,
         filesToClean    = refFilesToClean,
-        dirsToClean     = refDirsToClean
+        dirsToClean     = refDirsToClean,
+        generatedDumps   = refGeneratedDumps
         }
 
 -- | The normal 'DynFlags'. Note that they is not suitable for use in this form
@@ -811,6 +820,7 @@ defaultDynFlags mySettings =
         -- end of ghc -M values
         filesToClean   = panic "defaultDynFlags: No filesToClean",
         dirsToClean    = panic "defaultDynFlags: No dirsToClean",
+        generatedDumps = panic "defaultDynFlags: No generatedDumps",
         haddockOptions = Nothing,
         flags = defaultFlags,
         language = Nothing,
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index b6297a2d6d..1c7a389f35 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -41,6 +41,9 @@ import StaticFlags	( opt_ErrorSpans )
 
 import System.Exit	( ExitCode(..), exitWith )
 import Data.List
+import qualified Data.Set as Set
+import Data.IORef
+import Control.Monad
 import System.IO
 
 -- -----------------------------------------------------------------------------
@@ -208,19 +211,26 @@ mkDumpDoc hdr doc
 --	otherwise emit to stdout.
 dumpSDoc :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 dumpSDoc dflags dflag hdr doc
- = do	let mFile	= chooseDumpFile dflags dflag
- 	case mFile of
-		-- write the dump to a file
-		--	don't add the header in this case, we can see what kind
-		--	of dump it is from the filename.
-		Just fileName
-		 -> do	handle	<- openFile fileName AppendMode
-		 	hPrintDump handle doc
-		 	hClose handle
-
-		-- write the dump to stdout
-		Nothing
-		 -> do	printDump (mkDumpDoc hdr doc)
+ = do let mFile = chooseDumpFile dflags dflag
+      case mFile of
+            -- write the dump to a file
+            -- don't add the header in this case, we can see what kind
+            -- of dump it is from the filename.
+            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)
+                        handle <- openFile fileName mode
+                        hPrintDump handle doc
+                        hClose handle
+
+            -- write the dump to stdout
+            Nothing
+                 -> printDump (mkDumpDoc hdr doc)
 
 
 -- | Choose where to put a dump file based on DynFlags