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 | 93 | ||||
| -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, 135 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 diff --git a/testsuite/tests/driver/Makefile b/testsuite/tests/driver/Makefile index 50696a7052..f590c73019 100644 --- a/testsuite/tests/driver/Makefile +++ b/testsuite/tests/driver/Makefile @@ -609,3 +609,42 @@ 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 new file mode 100644 index 0000000000..910db6493a --- /dev/null +++ b/testsuite/tests/driver/T10320-with-rule.hs @@ -0,0 +1,9 @@ +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 new file mode 100644 index 0000000000..d070f82030 --- /dev/null +++ b/testsuite/tests/driver/T10320-without-rules.hs @@ -0,0 +1,4 @@ +module T10320 where + +n :: Int +n = 42 diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T index 5c0de6eaec..3ba8ed5bf2 100644 --- a/testsuite/tests/driver/all.T +++ b/testsuite/tests/driver/all.T @@ -460,3 +460,13 @@ 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']) |