Commit 8cba907a authored by tvv's avatar tvv Committed by Ben Gamari
Browse files

Create empty dump files when there was nothing to dump

This patch creates empty dump file when GHC was run with
`-ddump-rule-firings` (or `-ddump-rule-rewrites`) and `-ddump-to-file`
specified, and there were no rules applied. If dump already exists it
will be overwritten by empty one.

Test Plan: ./validate

Reviewers: austin, thomie, bgamari

Reviewed By: thomie, bgamari

Subscribers: thomie

Projects: #ghc

Differential Revision: https://phabricator.haskell.org/D1514

GHC Trac Issues: #10320
parent a12e47be
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
module T10320 where
{-# RULES "rule" forall x. f x = 42 #-}
f :: Int -> Int
f x = x
{-# NOINLINE [1] f #-}
n = f (0 :: Int)
module T10320 where
n :: Int
n = 42
......@@ -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'])
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