Commit c5597bb6 authored by Ben Gamari's avatar Ben Gamari 🐢
Browse files

Revert "Create empty dump files when there was nothing to dump"

This reverts commit 8cba907a which
broke `-ddump-to-file`.
parent a034031a
......@@ -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
......
......@@ -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
......
......@@ -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
--
......
......@@ -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
module T10320 where
{-# RULES "rule" forall x. f x = 42 #-}
f :: Int -> Int
f x = x
{-# NOINLINE [1] f #-}
n = f (0 :: Int)
......@@ -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'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment