diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 7 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 4 | ||||
| -rw-r--r-- | compiler/main/ErrUtils.hs | 90 |
3 files changed, 30 insertions, 71 deletions
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index f2bc57efd5..2e6bac81b8 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -649,13 +649,8 @@ 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 - -- #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) + evalP (pipeLoop start_phase input_fn) env state -- --------------------------------------------------------------------------- -- outer pipeline loop diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 4a443f9dbc..77797320a9 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 (Map FilePath Handle), + generatedDumps :: IORef (Set FilePath), -- hsc dynamic flags dumpFlags :: IntSet, @@ -1386,7 +1386,7 @@ initDynFlags dflags = do refFilesToClean <- newIORef [] refDirsToClean <- newIORef Map.empty refFilesToNotIntermediateClean <- newIORef [] - refGeneratedDumps <- newIORef Map.empty + refGeneratedDumps <- newIORef Set.empty refRtldInfo <- newIORef Nothing refRtccInfo <- newIORef Nothing wrapperNum <- newIORef emptyModuleEnv diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs index 5e585da26e..0677240522 100644 --- a/compiler/main/ErrUtils.hs +++ b/compiler/main/ErrUtils.hs @@ -33,7 +33,6 @@ module ErrUtils ( -- * Dump files dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer, mkDumpDoc, dumpSDoc, - openDumpFiles, closeDumpFiles, -- * Issuing messages during compilation putMsg, printInfoForUser, printOutputForUser, @@ -61,7 +60,7 @@ import System.Directory import System.Exit ( ExitCode(..), exitWith ) import System.FilePath ( takeDirectory, (</>) ) import Data.List -import qualified Data.Map as Map +import qualified Data.Set as Set import Data.IORef import Data.Maybe ( fromMaybe ) import Data.Ord @@ -300,15 +299,6 @@ 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, @@ -318,23 +308,6 @@ 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. @@ -350,16 +323,32 @@ dumpSDoc dflags print_unqual flag hdr doc = do let mFile = chooseDumpFile dflags flag dump_style = mkDumpStyle print_unqual case mFile of - 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 + 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 -- write the dump to stdout Nothing -> do @@ -368,31 +357,6 @@ 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 given 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 -- |