diff options
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 7 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 4 | ||||
| -rw-r--r-- | compiler/main/ErrUtils.hs | 90 | ||||
| -rw-r--r-- | testsuite/tests/driver/Makefile | 39 | ||||
| -rw-r--r-- | testsuite/tests/driver/T10320-with-rule.hs | 9 | ||||
| -rw-r--r-- | testsuite/tests/driver/T10320-without-rules.hs | 4 | ||||
| -rw-r--r-- | testsuite/tests/driver/all.T | 10 |
7 files changed, 30 insertions, 133 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 -- diff --git a/testsuite/tests/driver/Makefile b/testsuite/tests/driver/Makefile index f590c73019..50696a7052 100644 --- a/testsuite/tests/driver/Makefile +++ b/testsuite/tests/driver/Makefile @@ -609,42 +609,3 @@ T10182: "$(TEST_HC)" $(TEST_HC_OPTS) -c T10182.hs-boot "$(TEST_HC)" $(TEST_HC_OPTS) -c T10182a.hs "$(TEST_HC)" $(TEST_HC_OPTS) -c T10182.hs - -.PHONY: T10320a -T10320a: - # check if an empty .dump-rule-rewrites is created when no rules were applied - $(RM) -rf T10320dump - $(CP) T10320-without-rules.hs T10320.hs - "$(TEST_HC)" $(TEST_HC_OPTS) -O -c T10320.hs -dumpdir T10320dump -ddump-to-file -ddump-rule-rewrites - [ -e T10320dump/T10320.dump-rule-rewrites ] - -.PHONY: T10320b -T10320b: - # check if an empty .dump-rule-firings is created when no rules were applied - $(RM) -rf T10320dump - $(CP) T10320-without-rules.hs T10320.hs - "$(TEST_HC)" $(TEST_HC_OPTS) -O -c T10320.hs -dumpdir T10320dump -ddump-to-file -ddump-rule-firings - [ -e T10320dump/T10320.dump-rule-firings ] - -.PHONY: T10320c -T10320c: - # check if existing .dump-rule-rewrites has been rewritten by an empty one when no rules were applied - $(RM) -rf T10320dump - $(CP) T10320-with-rule.hs T10320.hs - "$(TEST_HC)" $(TEST_HC_OPTS) -O -c T10320.hs -dumpdir T10320dump -ddump-to-file -ddump-rule-rewrites # generate a non-empty dump - $(CP) T10320-without-rules.hs T10320.hs - "$(TEST_HC)" $(TEST_HC_OPTS) -O -c T10320.hs -dumpdir T10320dump -ddump-to-file -ddump-rule-rewrites - [ -e T10320dump/T10320.dump-rule-rewrites -a ! -s T10320dump/T10320.dump-rule-rewrites ] # check if the file exists and has zero size - -.PHONY: T10320d -T10320d: - # check if existing .dump-rule-firings has been rewritten by an empty one when no rules were applied - $(RM) -rf T10320dump - $(CP) T10320-with-rule.hs T10320.hs - "$(TEST_HC)" $(TEST_HC_OPTS) -O -c T10320.hs -dumpdir T10320dump -ddump-to-file -ddump-rule-firings # generate a non-empty dump - $(CP) T10320-without-rules.hs T10320.hs - "$(TEST_HC)" $(TEST_HC_OPTS) -O -c T10320.hs -dumpdir T10320dump -ddump-to-file -ddump-rule-firings - [ -e T10320dump/T10320.dump-rule-firings -a ! -s T10320dump/T10320.dump-rule-firings ] # check if the file exists and has zero size - -.PHONY: T10320 -T10320: T10320a T10320b T10320c T10320d diff --git a/testsuite/tests/driver/T10320-with-rule.hs b/testsuite/tests/driver/T10320-with-rule.hs deleted file mode 100644 index 910db6493a..0000000000 --- a/testsuite/tests/driver/T10320-with-rule.hs +++ /dev/null @@ -1,9 +0,0 @@ -module T10320 where - -{-# RULES "rule" forall x. f x = 42 #-} - -f :: Int -> Int -f x = x -{-# NOINLINE [1] f #-} - -n = f (0 :: Int) diff --git a/testsuite/tests/driver/T10320-without-rules.hs b/testsuite/tests/driver/T10320-without-rules.hs deleted file mode 100644 index d070f82030..0000000000 --- a/testsuite/tests/driver/T10320-without-rules.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T10320 where - -n :: Int -n = 42 diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T index 3ba8ed5bf2..5c0de6eaec 100644 --- a/testsuite/tests/driver/all.T +++ b/testsuite/tests/driver/all.T @@ -460,13 +460,3 @@ test('T9360b', normal, run_command, ['{compiler} -e "" --interactive']) test('T10970', normal, compile_and_run, ['-hide-all-packages -package base -package containers']) test('T10970a', normal, compile_and_run, ['']) test('T4931', normal, compile_and_run, ['']) -test('T10320', - [ - extra_clean([ - 'T10320dump/T10320.dump-rule-firings', - 'T10320dump/T10320.dump-rule-rewrites', - 'T10320dump', - 'T10320.hs' - ]), - ], - run_command, ['$MAKE -s --no-print-directory T10320']) |