Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/1dc458bf7ee5ca2749e62397617af291dadc891d >--------------------------------------------------------------- commit 1dc458bf7ee5ca2749e62397617af291dadc891d Author: Edward Z. Yang <[email protected]> Date: Sun May 15 11:57:51 2011 +0100 Make -ddump-to-file truncate existing files. Signed-off-by: Edward Z. Yang <[email protected]> >--------------------------------------------------------------- compiler/main/DynFlags.hs | 12 +++++++++++- compiler/main/ErrUtils.lhs | 36 +++++++++++++++++++++++------------- 2 files changed, 34 insertions(+), 14 deletions(-) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index d6cb85b..69185db 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 b6297a2..1c7a389 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 _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
