summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--compiler/ghc.mk1
-rw-r--r--compiler/ghci/Linker.hs8
-rw-r--r--compiler/iface/MkIface.hs4
-rw-r--r--compiler/main/CodeOutput.hs6
-rw-r--r--compiler/main/DriverMkDepend.hs5
-rw-r--r--compiler/main/DriverPipeline.hs70
-rw-r--r--compiler/main/DynFlags.hs32
-rw-r--r--compiler/main/ErrUtils.hs21
-rw-r--r--compiler/main/FileCleanup.hs249
-rw-r--r--compiler/main/GHC.hs3
-rw-r--r--compiler/main/GhcMake.hs81
-rw-r--r--compiler/main/HscTypes.hs3
-rw-r--r--compiler/main/PipelineMonad.hs3
-rw-r--r--compiler/main/SysTools.hs218
-rw-r--r--ghc/GHCi/UI.hs2
-rw-r--r--testsuite/tests/perf/compiler/all.T11
-rwxr-xr-xtestsuite/tests/perf/compiler/genT1370114
18 files changed, 427 insertions, 305 deletions
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 2ef2db45d3..d11a42bccc 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -165,6 +165,7 @@ Library
vectorise
Exposed-Modules:
+ FileCleanup
DriverBkp
BkpSyn
NameShape
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index a2a123c03b..bfd75ab26c 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -478,6 +478,7 @@ compiler_stage2_dll0_MODULES = \
FastString \
FastStringEnv \
FieldLabel \
+ FileCleanup \
Fingerprint \
FiniteMap \
ForeignCall \
diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs
index 10e789acc3..f32659017a 100644
--- a/compiler/ghci/Linker.hs
+++ b/compiler/ghci/Linker.hs
@@ -47,6 +47,7 @@ import UniqDSet
import FastString
import Platform
import SysTools
+import FileCleanup
-- Standard libraries
import Control.Monad
@@ -883,7 +884,8 @@ dynLoadObjs hsc_env pls objs = do
let platform = targetPlatform dflags
let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ]
let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ]
- (soFile, libPath , libName) <- newTempLibName dflags (soExt platform)
+ (soFile, libPath , libName) <-
+ newTempLibName dflags TFL_CurrentModule (soExt platform)
let
dflags2 = dflags {
-- We don't want the original ldInputs in
@@ -931,7 +933,9 @@ dynLoadObjs hsc_env pls objs = do
-- Note: We are loading packages with local scope, so to see the
-- symbols in this link we must link all loaded packages again.
linkDynLib dflags2 objs (pkgs_loaded pls)
- consIORef (filesToNotIntermediateClean dflags) soFile
+
+ -- if we got this far, extend the lifetime of the library file
+ changeTempFilesLifetime dflags TFL_GhcSession [soFile]
m <- loadDLL hsc_env soFile
case m of
Nothing -> return pls { temp_sos = (libPath, libName) : temp_sos pls }
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index dec7215715..78787c9827 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -966,9 +966,9 @@ lookupOccEnvL env k = lookupOccEnv env k `orElse` []
else return fp
oldMD5 dflags bh = do
- tmp <- newTempName dflags "bin"
+ tmp <- newTempName dflags CurrentModule "bin"
writeBinMem bh tmp
- tmp2 <- newTempName dflags "md5"
+ tmp2 <- newTempName dflags CurrentModule "md5"
let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
r <- system cmd
case r of
diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs
index 7c6dbdab53..34cada3ff9 100644
--- a/compiler/main/CodeOutput.hs
+++ b/compiler/main/CodeOutput.hs
@@ -23,9 +23,9 @@ import Cmm ( RawCmmGroup )
import HscTypes
import DynFlags
import Config
-import SysTools
import Stream (Stream)
import qualified Stream
+import FileCleanup
import ErrUtils
import Outputable
@@ -202,7 +202,7 @@ outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs
outputForeignStubs dflags mod location stubs
= do
let stub_h = mkStubPaths dflags (moduleName mod) location
- stub_c <- newTempName dflags "c"
+ stub_c <- newTempName dflags TFL_CurrentModule "c"
case stubs of
NoStubs ->
@@ -276,6 +276,6 @@ outputForeignFile dflags lang file_contents
LangCxx -> return "cpp"
LangObjc -> return "m"
LangObjcxx -> return "mm"
- fp <- newTempName dflags extension
+ fp <- newTempName dflags TFL_CurrentModule extension
writeFile fp file_contents
return fp
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
index 46fe4e0aad..dc18a31174 100644
--- a/compiler/main/DriverMkDepend.hs
+++ b/compiler/main/DriverMkDepend.hs
@@ -19,7 +19,7 @@ import GhcMonad
import DynFlags
import Util
import HscTypes
-import SysTools ( newTempName )
+import FileCleanup ( newTempName )
import qualified SysTools
import Module
import Digraph ( SCC(..) )
@@ -29,6 +29,7 @@ import Panic
import SrcLoc
import Data.List
import FastString
+import FileCleanup
import Exception
import ErrUtils
@@ -121,7 +122,7 @@ beginMkDependHS :: DynFlags -> IO MkDepFiles
beginMkDependHS dflags = do
-- open a new temp file in which to stuff the dependency info
-- as we go along.
- tmp_file <- newTempName dflags "dep"
+ tmp_file <- newTempName dflags TFL_CurrentModule "dep"
tmp_hdl <- openFile tmp_file WriteMode
-- open the makefile
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index e400461fb6..eed66b22c1 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -61,6 +61,7 @@ import Platform
import TcRnTypes
import Hooks
import qualified GHC.LanguageExtensions as LangExt
+import FileCleanup
import Exception
import System.Directory
@@ -86,7 +87,12 @@ preprocess :: HscEnv
preprocess hsc_env (filename, mb_phase) =
ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename)
runPipeline anyHsc hsc_env (filename, fmap RealPhase mb_phase)
- Nothing Temporary Nothing{-no ModLocation-} []{-no foreign objects-}
+ Nothing
+ -- We keep the processed file for the whole session to save on
+ -- duplicated work in ghci.
+ (Temporary TFL_GhcSession)
+ Nothing{-no ModLocation-}
+ []{-no foreign objects-}
-- ---------------------------------------------------------------------------
@@ -138,9 +144,11 @@ compileOne' m_tc_result mHscMessage
let flags = hsc_dflags hsc_env0
in do unless (gopt Opt_KeepHiFiles flags) $
- addFilesToClean flags [ml_hi_file $ ms_location summary]
+ addFilesToClean flags TFL_CurrentModule $
+ [ml_hi_file $ ms_location summary]
unless (gopt Opt_KeepOFiles flags) $
- addFilesToClean flags [ml_obj_file $ ms_location summary]
+ addFilesToClean flags TFL_GhcSession $
+ [ml_obj_file $ ms_location summary]
case (status, hsc_lang) of
(HscUpToDate, _) ->
@@ -165,7 +173,8 @@ compileOne' m_tc_result mHscMessage
in return hmi0 { hm_linkable = Just linkable }
(HscUpdateSig, _) -> do
output_fn <- getOutputFilename next_phase
- Temporary basename dflags next_phase (Just location)
+ (Temporary TFL_CurrentModule) basename dflags
+ next_phase (Just location)
-- #10660: Use the pipeline instead of calling
-- compileEmptyStub directly, so -dynamic-too gets
@@ -204,7 +213,8 @@ compileOne' m_tc_result mHscMessage
return hmi0 { hm_linkable = Just linkable }
(HscRecomp cgguts summary, _) -> do
output_fn <- getOutputFilename next_phase
- Temporary basename dflags next_phase (Just location)
+ (Temporary TFL_CurrentModule)
+ basename dflags next_phase (Just location)
-- We're in --make mode: finish the compilation pipeline.
_ <- runPipeline StopLn hsc_env
(output_fn,
@@ -225,9 +235,10 @@ compileOne' m_tc_result mHscMessage
input_fn = expectJust "compile:hs" (ml_hs_file location)
input_fnpp = ms_hspp_file summary
mod_graph = hsc_mod_graph hsc_env0
- needsTH = any (xopt LangExt.TemplateHaskell . ms_hspp_opts) mod_graph
- needsQQ = any (xopt LangExt.QuasiQuotes . ms_hspp_opts) mod_graph
- needsLinker = needsTH || needsQQ
+ needsLinker = any (\ModSummary {ms_hspp_opts} ->
+ xopt LangExt.TemplateHaskell ms_hspp_opts
+ || xopt LangExt.QuasiQuotes ms_hspp_opts
+ ) mod_graph
isDynWay = any (== WayDyn) (ways dflags0)
isProfWay = any (== WayProf) (ways dflags0)
internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0)
@@ -240,8 +251,8 @@ compileOne' m_tc_result mHscMessage
-- #8180 - when using TemplateHaskell, switch on -dynamic-too so
-- the linker can correctly load the object files. This isn't necessary
-- when using -fexternal-interpreter.
- dflags1 = if needsLinker && dynamicGhc && internalInterpreter &&
- not isDynWay && not isProfWay
+ dflags1 = if dynamicGhc && internalInterpreter &&
+ not isDynWay && not isProfWay && needsLinker
then gopt_set dflags0 Opt_BuildDynamicToo
else dflags0
@@ -299,8 +310,9 @@ compileForeign hsc_env lang stub_c = do
LangObjcxx -> Cobjcxx
(_, stub_o) <- runPipeline StopLn hsc_env
(stub_c, Just (RealPhase phase))
- Nothing Temporary Nothing{-no ModLocation-} []
-
+ Nothing (Temporary TFL_GhcSession)
+ Nothing{-no ModLocation-}
+ []
return stub_o
compileStub :: HscEnv -> FilePath -> IO FilePath
@@ -315,7 +327,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
-- so that ranlib on OS X doesn't complain, see
-- http://ghc.haskell.org/trac/ghc/ticket/12673
-- and https://github.com/haskell/cabal/issues/2257
- empty_stub <- newTempName dflags "c"
+ empty_stub <- newTempName dflags TFL_CurrentModule "c"
let src = text "int" <+> ppr (mkModule (thisPackage dflags) mod_name) <+> text "= 0;"
writeFile empty_stub (showSDoc dflags (pprCode CStyle src))
_ <- runPipeline StopLn hsc_env
@@ -535,10 +547,10 @@ compileFile hsc_env stop_phase (src, mb_phase) = do
-- When linking, the -o argument refers to the linker's output.
-- otherwise, we use it as the name for the pipeline's output.
output
- -- If we are dong -fno-code, then act as if the output is
+ -- If we are doing -fno-code, then act as if the output is
-- 'Temporary'. This stops GHC trying to copy files to their
-- final location.
- | HscNothing <- hscTarget dflags = Temporary
+ | HscNothing <- hscTarget dflags = Temporary TFL_CurrentModule
| StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent
-- -o foo applies to linker
| isJust mb_o_file = SpecificFile
@@ -696,7 +708,7 @@ pipeLoop phase input_fn = do
-- copy the file, remembering to prepend a {-# LINE #-} pragma so that
-- further compilation stages can tell what the original filename was.
case output_spec env of
- Temporary ->
+ Temporary _ ->
return (dflags, input_fn)
output ->
do pst <- getPipeState
@@ -780,7 +792,9 @@ getOutputFilename stop_phase output basename dflags next_phase maybe_location
Nothing ->
panic "SpecificFile: No filename"
| keep_this_output = persistent_fn
- | otherwise = newTempName dflags suffix
+ | Temporary lifetime <- output = newTempName dflags lifetime suffix
+ | otherwise = newTempName dflags TFL_CurrentModule
+ suffix
where
hcsuf = hcSuf dflags
odir = objectDir dflags
@@ -1238,7 +1252,8 @@ runPhase (RealPhase cc_phase) input_fn dflags
runPhase (RealPhase Splitter) input_fn dflags
= do -- tmp_pfx is the prefix used for the split .s files
- split_s_prefix <- liftIO $ SysTools.newTempName dflags "split"
+ split_s_prefix <-
+ liftIO $ newTempName dflags TFL_CurrentModule "split"
let n_files_fn = split_s_prefix
liftIO $ SysTools.runSplit dflags
@@ -1255,7 +1270,7 @@ runPhase (RealPhase Splitter) input_fn dflags
setDynFlags dflags'
-- Remember to delete all these files
- liftIO $ addFilesToClean dflags'
+ liftIO $ addFilesToClean dflags' TFL_CurrentModule $
[ split_s_prefix ++ "__" ++ show n ++ ".s"
| n <- [1..n_files]]
@@ -1401,7 +1416,7 @@ runPhase (RealPhase SplitAs) _input_fn dflags
if null foreign_os
then return ()
else liftIO $ do
- tmp_split_1 <- newTempName dflags osuf
+ tmp_split_1 <- newTempName dflags TFL_CurrentModule osuf
let split_1 = split_obj 1
copyFile split_1 tmp_split_1
removeFile split_1
@@ -1613,8 +1628,8 @@ getLocation src_flavour mod_name = do
mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath
mkExtraObj dflags extn xs
- = do cFile <- newTempName dflags extn
- oFile <- newTempName dflags "o"
+ = do cFile <- newTempName dflags TFL_CurrentModule extn
+ oFile <- newTempName dflags TFL_GhcSession "o"
writeFile cFile xs
ccInfo <- liftIO $ getCompilerInfo dflags
SysTools.runCc dflags
@@ -2031,8 +2046,9 @@ maybeCreateManifest dflags exe_filename
-- the binary itself using windres:
if not (gopt Opt_EmbedManifest dflags) then return [] else do
- rc_filename <- newTempName dflags "rc"
- rc_obj_filename <- newTempName dflags (objectSuf dflags)
+ rc_filename <- newTempName dflags TFL_CurrentModule "rc"
+ rc_obj_filename <-
+ newTempName dflags TFL_GhcSession (objectSuf dflags)
writeFile rc_filename $
"1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
@@ -2121,7 +2137,7 @@ doCpp dflags raw input_fn output_fn = do
pkgs = catMaybes (map (lookupPackage dflags) uids)
mb_macro_include <-
if not (null pkgs) && gopt Opt_VersionMacros dflags
- then do macro_stub <- newTempName dflags "h"
+ then do macro_stub <- newTempName dflags TFL_CurrentModule "h"
writeFile macro_stub (generatePackageVersionMacros pkgs)
-- Include version macros for every *exposed* package.
-- Without -hide-all-packages and with a package database
@@ -2248,14 +2264,14 @@ joinObjectFiles dflags o_files output_fn = do
ccInfo <- getCompilerInfo dflags
if ldIsGnuLd
then do
- script <- newTempName dflags "ldscript"
+ script <- newTempName dflags TFL_CurrentModule "ldscript"
cwd <- getCurrentDirectory
let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files
writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"
ld_r [SysTools.FileOption "" script] ccInfo
else if sLdSupportsFilelist mySettings
then do
- filelist <- newTempName dflags "filelist"
+ filelist <- newTempName dflags TFL_CurrentModule "filelist"
writeFile filelist $ unlines o_files
ld_r [SysTools.Option "-Wl,-filelist",
SysTools.FileOption "-Wl," filelist] ccInfo
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index a166993089..8a4f1c3e1d 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -155,6 +155,9 @@ module DynFlags (
-- * Linker/compiler information
LinkerInfo(..),
CompilerInfo(..),
+
+ -- * File cleanup
+ FilesToClean(..), emptyFilesToClean
) where
#include "HsVersions.h"
@@ -840,9 +843,8 @@ data DynFlags = DynFlags {
-- Temporary files
-- These have to be IORefs, because the defaultCleanupHandler needs to
-- know what to clean when an exception happens
- filesToClean :: IORef [FilePath],
+ filesToClean :: IORef FilesToClean,
dirsToClean :: IORef (Map FilePath FilePath),
- filesToNotIntermediateClean :: IORef [FilePath],
-- The next available suffix to uniquely name a temp file, updated atomically
nextTempSuffix :: IORef Int,
@@ -1504,9 +1506,8 @@ initDynFlags dflags = do
= platformOS (targetPlatform dflags) /= OSMinGW32
refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo
refNextTempSuffix <- newIORef 0
- refFilesToClean <- newIORef []
+ refFilesToClean <- newIORef emptyFilesToClean
refDirsToClean <- newIORef Map.empty
- refFilesToNotIntermediateClean <- newIORef []
refGeneratedDumps <- newIORef Set.empty
refRtldInfo <- newIORef Nothing
refRtccInfo <- newIORef Nothing
@@ -1530,7 +1531,6 @@ initDynFlags dflags = do
nextTempSuffix = refNextTempSuffix,
filesToClean = refFilesToClean,
dirsToClean = refDirsToClean,
- filesToNotIntermediateClean = refFilesToNotIntermediateClean,
generatedDumps = refGeneratedDumps,
nextWrapperNum = wrapperNum,
useUnicode = canUseUnicode,
@@ -1647,7 +1647,6 @@ defaultDynFlags mySettings =
nextTempSuffix = panic "defaultDynFlags: No nextTempSuffix",
filesToClean = panic "defaultDynFlags: No filesToClean",
dirsToClean = panic "defaultDynFlags: No dirsToClean",
- filesToNotIntermediateClean = panic "defaultDynFlags: No filesToNotIntermediateClean",
generatedDumps = panic "defaultDynFlags: No generatedDumps",
haddockOptions = Nothing,
dumpFlags = EnumSet.empty,
@@ -5326,3 +5325,24 @@ decodeSize str
foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO ()
foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()
+
+-- -----------------------------------------------------------------------------
+-- Types for managing temporary files.
+--
+-- these are here because FilesToClean is used in DynFlags
+
+-- | A collection of files that must be deleted before ghc exits.
+-- The current collection
+-- is stored in an IORef in DynFlags, 'filesToClean'.
+data FilesToClean = FilesToClean {
+ ftcGhcSession :: !(Set FilePath),
+ -- ^ Files that will be deleted at the end of runGhc(T)
+ ftcCurrentModule :: !(Set FilePath)
+ -- ^ Files that will be deleted the next time
+ -- 'FileCleanup.cleanCurrentModuleTempFiles' is called, or otherwise at the
+ -- end of the session.
+ }
+
+-- | An empty FilesToClean
+emptyFilesToClean :: FilesToClean
+emptyFilesToClean = FilesToClean Set.empty Set.empty
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index 64d23c7e41..c0127b2a27 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -52,6 +52,7 @@ module ErrUtils (
debugTraceMsg,
ghcExit,
prettyPrintGhcErrors,
+ traceCmd
) where
#include "HsVersions.h"
@@ -673,3 +674,23 @@ isWarnMsgFatal :: DynFlags -> WarnMsg -> Bool
isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}
= wopt_fatal wflag dflags
isWarnMsgFatal dflags _ = gopt Opt_WarnIsError dflags
+
+traceCmd :: DynFlags -> String -> String -> IO a -> IO a
+-- trace the command (at two levels of verbosity)
+traceCmd dflags phase_name cmd_line action
+ = do { let verb = verbosity dflags
+ ; showPass dflags phase_name
+ ; debugTraceMsg dflags 3 (text cmd_line)
+ ; case flushErr dflags of
+ FlushErr io -> io
+
+ -- And run it!
+ ; action `catchIO` handle_exn verb
+ }
+ where
+ handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
+ ; debugTraceMsg dflags 2
+ (text "Failed:"
+ <+> text cmd_line
+ <+> text (show exn))
+ ; throwGhcExceptionIO (ProgramError (show exn))}
diff --git a/compiler/main/FileCleanup.hs b/compiler/main/FileCleanup.hs
new file mode 100644
index 0000000000..f4c30d6112
--- /dev/null
+++ b/compiler/main/FileCleanup.hs
@@ -0,0 +1,249 @@
+{-# LANGUAGE CPP #-}
+module FileCleanup
+ ( TempFileLifetime(..)
+ , cleanTempDirs, cleanTempFiles, cleanCurrentModuleTempFiles
+ , addFilesToClean, changeTempFilesLifetime
+ , newTempName, newTempLibName
+ ) where
+
+import DynFlags
+import ErrUtils
+import Outputable
+import Util
+import Exception
+import DriverPhases
+
+import Control.Monad
+import Data.List
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Data.IORef
+import System.Directory
+import System.FilePath
+import System.IO.Error
+
+#if !defined(mingw32_HOST_OS)
+import qualified System.Posix.Internals
+#endif
+
+-- | Used when a temp file is created. This determines which component Set of
+-- FilesToClean will get the temp file
+data TempFileLifetime
+ = TFL_CurrentModule
+ -- ^ A file with lifetime TFL_CurrentModule will be cleaned up at the
+ -- end of upweep_mod
+ | TFL_GhcSession
+ -- ^ A file with lifetime TFL_GhcSession will be cleaned up at the end of
+ -- runGhc(T)
+ deriving (Show)
+
+cleanTempDirs :: DynFlags -> IO ()
+cleanTempDirs dflags
+ = unless (gopt Opt_KeepTmpFiles dflags)
+ $ mask_
+ $ do let ref = dirsToClean dflags
+ ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)
+ removeTmpDirs dflags (Map.elems ds)
+
+-- | Delete all files in @filesToClean dflags@.
+cleanTempFiles :: DynFlags -> IO ()
+cleanTempFiles dflags
+ = unless (gopt Opt_KeepTmpFiles dflags)
+ $ mask_
+ $ do let ref = filesToClean dflags
+ to_delete <- atomicModifyIORef' ref $
+ \FilesToClean
+ { ftcCurrentModule = cm_files
+ , ftcGhcSession = gs_files
+ } -> ( emptyFilesToClean
+ , Set.toList cm_files ++ Set.toList gs_files)
+ removeTmpFiles dflags to_delete
+
+-- | Delete all files in @filesToClean dflags@. That have lifetime
+-- TFL_CurrentModule.
+-- If a file must be cleaned eventually, but must survive a
+-- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession.
+cleanCurrentModuleTempFiles :: DynFlags -> IO ()
+cleanCurrentModuleTempFiles dflags
+ = unless (gopt Opt_KeepTmpFiles dflags)
+ $ mask_
+ $ do let ref = filesToClean dflags
+ to_delete <- atomicModifyIORef' ref $
+ \ftc@FilesToClean{ftcCurrentModule = cm_files} ->
+ (ftc {ftcCurrentModule = Set.empty}, Set.toList cm_files)
+ removeTmpFiles dflags to_delete
+
+-- | Ensure that new_files are cleaned on the next call of
+-- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime.
+-- If any of new_files are already tracked, they will have their lifetime
+-- updated.
+addFilesToClean :: DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
+addFilesToClean dflags lifetime new_files = modifyIORef' (filesToClean dflags) $
+ \FilesToClean
+ { ftcCurrentModule = cm_files
+ , ftcGhcSession = gs_files
+ } -> case lifetime of
+ TFL_CurrentModule -> FilesToClean
+ { ftcCurrentModule = cm_files `Set.union` new_files_set
+ , ftcGhcSession = gs_files `Set.difference` new_files_set
+ }
+ TFL_GhcSession -> FilesToClean
+ { ftcCurrentModule = cm_files `Set.difference` new_files_set
+ , ftcGhcSession = gs_files `Set.union` new_files_set
+ }
+ where
+ new_files_set = Set.fromList new_files
+
+-- | Update the lifetime of files already being tracked. If any files are
+-- not being tracked they will be discarded.
+changeTempFilesLifetime :: DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
+changeTempFilesLifetime dflags lifetime files = do
+ FilesToClean
+ { ftcCurrentModule = cm_files
+ , ftcGhcSession = gs_files
+ } <- readIORef (filesToClean dflags)
+ let old_set = case lifetime of
+ TFL_CurrentModule -> gs_files
+ TFL_GhcSession -> cm_files
+ existing_files = [f | f <- files, f `Set.member` old_set]
+ addFilesToClean dflags lifetime existing_files
+
+-- Return a unique numeric temp file suffix
+newTempSuffix :: DynFlags -> IO Int
+newTempSuffix dflags =
+ atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n)
+
+-- Find a temporary name that doesn't already exist.
+newTempName :: DynFlags -> TempFileLifetime -> Suffix -> IO FilePath
+newTempName dflags lifetime extn
+ = do d <- getTempDir dflags
+ findTempName (d </> "ghc_") -- See Note [Deterministic base name]
+ where
+ findTempName :: FilePath -> IO FilePath
+ findTempName prefix
+ = do n <- newTempSuffix dflags
+ let filename = prefix ++ show n <.> extn
+ b <- doesFileExist filename
+ if b then findTempName prefix
+ else do -- clean it up later
+ addFilesToClean dflags lifetime [filename]
+ return filename
+
+newTempLibName :: DynFlags -> TempFileLifetime -> Suffix
+ -> IO (FilePath, FilePath, String)
+newTempLibName dflags lifetime extn
+ = do d <- getTempDir dflags
+ findTempName d ("ghc_")
+ where
+ findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)
+ findTempName dir prefix
+ = do n <- newTempSuffix dflags -- See Note [Deterministic base name]
+ let libname = prefix ++ show n
+ filename = dir </> "lib" ++ libname <.> extn
+ b <- doesFileExist filename
+ if b then findTempName dir prefix
+ else do -- clean it up later
+ addFilesToClean dflags lifetime [filename]
+ return (filename, dir, libname)
+
+
+-- Return our temporary directory within tmp_dir, creating one if we
+-- don't have one yet.
+getTempDir :: DynFlags -> IO FilePath
+getTempDir dflags = do
+ mapping <- readIORef dir_ref
+ case Map.lookup tmp_dir mapping of
+ Nothing -> do
+ pid <- getProcessID
+ let prefix = tmp_dir </> "ghc" ++ show pid ++ "_"
+ mask_ $ mkTempDir prefix
+ Just dir -> return dir
+ where
+ tmp_dir = tmpDir dflags
+ dir_ref = dirsToClean dflags
+
+ mkTempDir :: FilePath -> IO FilePath
+ mkTempDir prefix = do
+ n <- newTempSuffix dflags
+ let our_dir = prefix ++ show n
+
+ -- 1. Speculatively create our new directory.
+ createDirectory our_dir
+
+ -- 2. Update the dirsToClean mapping unless an entry already exists
+ -- (i.e. unless another thread beat us to it).
+ their_dir <- atomicModifyIORef' dir_ref $ \mapping ->
+ case Map.lookup tmp_dir mapping of
+ Just dir -> (mapping, Just dir)
+ Nothing -> (Map.insert tmp_dir our_dir mapping, Nothing)
+
+ -- 3. If there was an existing entry, return it and delete the
+ -- directory we created. Otherwise return the directory we created.
+ case their_dir of
+ Nothing -> do
+ debugTraceMsg dflags 2 $
+ text "Created temporary directory:" <+> text our_dir
+ return our_dir
+ Just dir -> do
+ removeDirectory our_dir
+ return dir
+ `catchIO` \e -> if isAlreadyExistsError e
+ then mkTempDir prefix else ioError e
+
+{- Note [Deterministic base name]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The filename of temporary files, especially the basename of C files, can end
+up in the output in some form, e.g. as part of linker debug information. In the
+interest of bit-wise exactly reproducible compilation (#4012), the basename of
+the temporary file no longer contains random information (it used to contain
+the process id).
+
+This is ok, as the temporary directory used contains the pid (see getTempDir).
+-}
+removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
+removeTmpDirs dflags ds
+ = traceCmd dflags "Deleting temp dirs"
+ ("Deleting: " ++ unwords ds)
+ (mapM_ (removeWith dflags removeDirectory) ds)
+
+removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
+removeTmpFiles dflags fs
+ = warnNon $
+ traceCmd dflags "Deleting temp files"
+ ("Deleting: " ++ unwords deletees)
+ (mapM_ (removeWith dflags removeFile) deletees)
+ where
+ -- Flat out refuse to delete files that are likely to be source input
+ -- files (is there a worse bug than having a compiler delete your source
+ -- files?)
+ --
+ -- Deleting source files is a sign of a bug elsewhere, so prominently flag
+ -- the condition.
+ warnNon act
+ | null non_deletees = act
+ | otherwise = do
+ putMsg dflags (text "WARNING - NOT deleting source files:"
+ <+> hsep (map text non_deletees))
+ act
+
+ (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
+
+removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
+removeWith dflags remover f = remover f `catchIO`
+ (\e ->
+ let msg = if isDoesNotExistError e
+ then text "Warning: deleting non-existent" <+> text f
+ else text "Warning: exception raised when deleting"
+ <+> text f <> colon
+ $$ text (show e)
+ in debugTraceMsg dflags 2 msg
+ )
+
+#if defined(mingw32_HOST_OS)
+-- relies on Int == Int32 on Windows
+foreign import ccall unsafe "_getpid" getProcessID :: IO Int
+#else
+getProcessID :: IO Int
+getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
+#endif
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index af00dab4f2..eda3471ece 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -333,8 +333,9 @@ import qualified Parser
import Lexer
import ApiAnnotation
import qualified GHC.LanguageExtensions as LangExt
-import Data.Set (Set)
+import FileCleanup
+import Data.Set (Set)
import System.Directory ( doesFileExist )
import Data.Maybe
import Data.List ( find )
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index e11503b9d1..134a0607bc 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-}
+{-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
-- NB: we specifically ignore deprecations. GHC 7.6 marks the .QSem module as
-- deprecated, although it became un-deprecated later. As a result, using 7.6
@@ -59,7 +60,6 @@ import Outputable
import Panic
import SrcLoc
import StringBuffer
-import SysTools
import UniqFM
import UniqDSet
import TcBackpack
@@ -68,6 +68,7 @@ import UniqSet
import Util
import qualified GHC.LanguageExtensions as LangExt
import NameEnv
+import FileCleanup
import Data.Either ( rights, partitionEithers )
import qualified Data.Map as Map
@@ -373,10 +374,7 @@ load' how_much mHscMessage mod_graph = do
mg = stable_mg ++ unstable_mg
-- clean up between compilations
- let cleanup hsc_env = intermediateCleanTempFiles (hsc_dflags hsc_env)
- (flattenSCCs mg2_with_srcimps)
- hsc_env
-
+ let cleanup = cleanCurrentModuleTempFiles . hsc_dflags
liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
2 (ppr mg))
@@ -407,7 +405,7 @@ load' how_much mHscMessage mod_graph = do
-- Clean up after ourselves
hsc_env1 <- getSession
- liftIO $ intermediateCleanTempFiles dflags modsDone hsc_env1
+ liftIO $ cleanCurrentModuleTempFiles dflags
-- Issue a warning for the confusing case where the user
-- said '-o foo' but we're not going to do any linking.
@@ -448,29 +446,42 @@ load' how_much mHscMessage mod_graph = do
let mods_to_zap_names
= findPartiallyCompletedCycles modsDone_names
mg2_with_srcimps
- let mods_to_keep
- = filter ((`Set.notMember` mods_to_zap_names).ms_mod)
- modsDone
-
+ let (mods_to_clean, mods_to_keep) =
+ partition ((`Set.member` mods_to_zap_names).ms_mod) modsDone
hsc_env1 <- getSession
- let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
- (hsc_HPT hsc_env1)
+ let hpt4 = hsc_HPT hsc_env1
+ -- We must change the lifetime to TFL_CurrentModule for any temp
+ -- file created for an element of mod_to_clean during the upsweep.
+ -- These include preprocessed files and object files for loaded
+ -- modules.
+ unneeded_temps = concat
+ [ms_hspp_file : object_files
+ | ModSummary{ms_mod, ms_hspp_file} <- mods_to_clean
+ , let object_files = maybe [] linkableObjs $
+ lookupHpt hpt4 (moduleName ms_mod)
+ >>= hm_linkable
+ ]
+ liftIO $
+ changeTempFilesLifetime dflags TFL_CurrentModule unneeded_temps
+ liftIO $ cleanCurrentModuleTempFiles dflags
+
+ let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
+ hpt4
-- Clean up after ourselves
- liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1
-- there should be no Nothings where linkables should be, now
let just_linkables =
isNoLink (ghcLink dflags)
|| allHpt (isJust.hm_linkable)
(filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface)
- hpt4)
+ hpt5)
ASSERT( just_linkables ) do
-- Link everything together
- linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4
+ linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt5
- modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 }
+ modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 }
loadFinish Failed linkresult
@@ -518,23 +529,6 @@ discardIC hsc_env
this_pkg = thisPackage dflags
old_name = ic_name old_ic
-intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO ()
-intermediateCleanTempFiles dflags summaries hsc_env
- = do notIntermediate <- readIORef (filesToNotIntermediateClean dflags)
- cleanTempFilesExcept dflags (notIntermediate ++ except)
- where
- except =
- -- Save preprocessed files. The preprocessed file *might* be
- -- the same as the source file, but that doesn't do any
- -- harm.
- map ms_hspp_file summaries ++
- -- Save object files for loaded modules. The point of this
- -- is that we might have generated and compiled a stub C
- -- file, and in the case of GHCi the object file will be a
- -- temporary file which we must not remove because we need
- -- to load/link it later.
- hptObjs (hsc_HPT hsc_env)
-
-- | If there is no -o option, guess the name of target executable
-- by using top-level source file name as a base.
guessOutputFile :: GhcMonad m => m ()
@@ -927,7 +921,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
-- compilation for that module is finished) without having to
-- worry about accidentally deleting a simultaneous compile's
-- important files.
- lcl_files_to_clean <- newIORef []
+ lcl_files_to_clean <- newIORef emptyFilesToClean
let lcl_dflags = dflags { log_action = parLogAction log_queue
, filesToClean = lcl_files_to_clean }
@@ -960,9 +954,12 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
-- Add the remaining files that weren't cleaned up to the
-- global filesToClean ref, for cleanup later.
- files_kept <- readIORef (filesToClean lcl_dflags)
- addFilesToClean dflags files_kept
-
+ FilesToClean
+ { ftcCurrentModule = cm_files
+ , ftcGhcSession = gs_files
+ } <- readIORef (filesToClean lcl_dflags)
+ addFilesToClean dflags TFL_CurrentModule $ Set.toList cm_files
+ addFilesToClean dflags TFL_GhcSession $ Set.toList gs_files
-- Kill all the workers, masking interrupts (since killThread is
-- interruptible). XXX: This is not ideal.
@@ -1971,14 +1968,10 @@ enableCodeGenForTH target nodemap =
} <- ms
, ms_mod `Set.member` needs_codegen_set
= do
- let add_intermediate_file f =
- consIORef (filesToNotIntermediateClean dflags) f
- new_temp_file suf dynsuf = do
- tn <- newTempName dflags suf
+ let new_temp_file suf dynsuf = do
+ tn <- newTempName dflags TFL_CurrentModule suf
let dyn_tn = tn -<.> dynsuf
- add_intermediate_file tn
- add_intermediate_file dyn_tn
- addFilesToClean dflags [dyn_tn]
+ addFilesToClean dflags TFL_GhcSession [dyn_tn]
return tn
-- We don't want to create .o or .hi files unless we have been asked
-- to by the user. But we need them, so we patch their locations in
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 70af19de9b..c9e4f89158 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -40,7 +40,6 @@ module HscTypes (
addToHpt, addListToHpt, lookupHptDirectly, listToHpt,
hptCompleteSigs,
hptInstances, hptRules, hptVectInfo, pprHPT,
- hptObjs,
-- * State relating to known packages
ExternalPackageState(..), EpsStats(..), addEpsInStats,
@@ -688,8 +687,6 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps
-- And get its dfuns
, thing <- things ]
-hptObjs :: HomePackageTable -> [FilePath]
-hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsHpt hpt))
{-
************************************************************************
diff --git a/compiler/main/PipelineMonad.hs b/compiler/main/PipelineMonad.hs
index e0904b8ad3..c8345276fa 100644
--- a/compiler/main/PipelineMonad.hs
+++ b/compiler/main/PipelineMonad.hs
@@ -15,6 +15,7 @@ import DynFlags
import DriverPhases
import HscTypes
import Module
+import FileCleanup (TempFileLifetime)
import Control.Monad
@@ -72,7 +73,7 @@ data PipeState = PipeState {
}
data PipelineOutput
- = Temporary
+ = Temporary TempFileLifetime
-- ^ Output should be to a temporary file: we're going to
-- run more compilation steps on this output later.
| Persistent
diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index 612206bc5d..0a19feb2ce 100644
--- a/compiler/main/SysTools.hs
+++ b/compiler/main/SysTools.hs
@@ -37,24 +37,15 @@ module SysTools (
copy,
copyWithHeader,
- -- Temporary-file management
- setTmpDir,
- newTempName, newTempLibName,
- cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
- addFilesToClean,
-
Option(..),
-- frameworks
getPkgFrameworkOpts,
getFrameworkOpts
-
-
) where
#include "HsVersions.h"
-import DriverPhases
import Module
import Packages
import Config
@@ -65,11 +56,11 @@ import Platform
import Util
import DynFlags
import Exception
+import FileCleanup
import LlvmCodeGen.Base (llvmVersionStr, supportedLlvmVersion)
import Data.IORef
-import Control.Monad
import System.Exit
import System.Environment
import System.FilePath
@@ -78,19 +69,15 @@ import System.IO.Error as IO
import System.Directory
import Data.Char
import Data.List
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-#if !defined(mingw32_HOST_OS)
-import qualified System.Posix.Internals
-#else /* Must be Win32 */
-import Foreign
-import Foreign.C.String
+#if defined(mingw32_HOST_OS)
#if MIN_VERSION_Win32(2,5,0)
import qualified System.Win32.Types as Win32
#else
import qualified System.Win32.Info as Win32
#endif
+import Foreign
+import Foreign.C.String
import System.Win32.Types (DWORD, LPTSTR, HANDLE)
import System.Win32.Types (failIfNull, failIf, iNVALID_HANDLE_VALUE)
import System.Win32.File (createFile,closeHandle, gENERIC_READ, fILE_SHARE_READ, oPEN_EXISTING, fILE_ATTRIBUTE_NORMAL, fILE_FLAG_BACKUP_SEMANTICS )
@@ -1035,179 +1022,6 @@ copyWithHeader dflags purpose maybe_header from to = do
hPutStr h str
hSetBinaryMode h True
-
-
-{-
-************************************************************************
-* *
-\subsection{Managing temporary files
-* *
-************************************************************************
--}
-
-cleanTempDirs :: DynFlags -> IO ()
-cleanTempDirs dflags
- = unless (gopt Opt_KeepTmpFiles dflags)
- $ mask_
- $ do let ref = dirsToClean dflags
- ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)
- removeTmpDirs dflags (Map.elems ds)
-
-cleanTempFiles :: DynFlags -> IO ()
-cleanTempFiles dflags
- = unless (gopt Opt_KeepTmpFiles dflags)
- $ mask_
- $ do let ref = filesToClean dflags
- fs <- atomicModifyIORef' ref $ \fs -> ([],fs)
- removeTmpFiles dflags fs
-
-cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
-cleanTempFilesExcept dflags dont_delete
- = unless (gopt Opt_KeepTmpFiles dflags)
- $ mask_
- $ do let ref = filesToClean dflags
- to_delete <- atomicModifyIORef' ref $ \files ->
- let res@(_to_keep, _to_delete) =
- partition (`Set.member` dont_delete_set) files
- in res
- removeTmpFiles dflags to_delete
- where dont_delete_set = Set.fromList dont_delete
-
-
--- Return a unique numeric temp file suffix
-newTempSuffix :: DynFlags -> IO Int
-newTempSuffix dflags = atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n)
-
--- Find a temporary name that doesn't already exist.
-newTempName :: DynFlags -> Suffix -> IO FilePath
-newTempName dflags extn
- = do d <- getTempDir dflags
- findTempName (d </> "ghc_") -- See Note [Deterministic base name]
- where
- findTempName :: FilePath -> IO FilePath
- findTempName prefix
- = do n <- newTempSuffix dflags
- let filename = prefix ++ show n <.> extn
- b <- doesFileExist filename
- if b then findTempName prefix
- else do -- clean it up later
- consIORef (filesToClean dflags) filename
- return filename
-
-newTempLibName :: DynFlags -> Suffix -> IO (FilePath, FilePath, String)
-newTempLibName dflags extn
- = do d <- getTempDir dflags
- findTempName d ("ghc_")
- where
- findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)
- findTempName dir prefix
- = do n <- newTempSuffix dflags -- See Note [Deterministic base name]
- let libname = prefix ++ show n
- filename = dir </> "lib" ++ libname <.> extn
- b <- doesFileExist filename
- if b then findTempName dir prefix
- else do -- clean it up later
- consIORef (filesToClean dflags) filename
- return (filename, dir, libname)
-
-
--- Return our temporary directory within tmp_dir, creating one if we
--- don't have one yet.
-getTempDir :: DynFlags -> IO FilePath
-getTempDir dflags = do
- mapping <- readIORef dir_ref
- case Map.lookup tmp_dir mapping of
- Nothing -> do
- pid <- getProcessID
- let prefix = tmp_dir </> "ghc" ++ show pid ++ "_"
- mask_ $ mkTempDir prefix
- Just dir -> return dir
- where
- tmp_dir = tmpDir dflags
- dir_ref = dirsToClean dflags
-
- mkTempDir :: FilePath -> IO FilePath
- mkTempDir prefix = do
- n <- newTempSuffix dflags
- let our_dir = prefix ++ show n
-
- -- 1. Speculatively create our new directory.
- createDirectory our_dir
-
- -- 2. Update the dirsToClean mapping unless an entry already exists
- -- (i.e. unless another thread beat us to it).
- their_dir <- atomicModifyIORef' dir_ref $ \mapping ->
- case Map.lookup tmp_dir mapping of
- Just dir -> (mapping, Just dir)
- Nothing -> (Map.insert tmp_dir our_dir mapping, Nothing)
-
- -- 3. If there was an existing entry, return it and delete the
- -- directory we created. Otherwise return the directory we created.
- case their_dir of
- Nothing -> do
- debugTraceMsg dflags 2 $
- text "Created temporary directory:" <+> text our_dir
- return our_dir
- Just dir -> do
- removeDirectory our_dir
- return dir
- `catchIO` \e -> if isAlreadyExistsError e
- then mkTempDir prefix else ioError e
-
--- Note [Deterministic base name]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- The filename of temporary files, especially the basename of C files, can end
--- up in the output in some form, e.g. as part of linker debug information. In the
--- interest of bit-wise exactly reproducible compilation (#4012), the basename of
--- the temporary file no longer contains random information (it used to contain
--- the process id).
---
--- This is ok, as the temporary directory used contains the pid (see getTempDir).
-
-addFilesToClean :: DynFlags -> [FilePath] -> IO ()
--- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
-addFilesToClean dflags new_files
- = atomicModifyIORef' (filesToClean dflags) $ \files -> (new_files++files, ())
-
-removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
-removeTmpDirs dflags ds
- = traceCmd dflags "Deleting temp dirs"
- ("Deleting: " ++ unwords ds)
- (mapM_ (removeWith dflags removeDirectory) ds)
-
-removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
-removeTmpFiles dflags fs
- = warnNon $
- traceCmd dflags "Deleting temp files"
- ("Deleting: " ++ unwords deletees)
- (mapM_ (removeWith dflags removeFile) deletees)
- where
- -- Flat out refuse to delete files that are likely to be source input
- -- files (is there a worse bug than having a compiler delete your source
- -- files?)
- --
- -- Deleting source files is a sign of a bug elsewhere, so prominently flag
- -- the condition.
- warnNon act
- | null non_deletees = act
- | otherwise = do
- putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
- act
-
- (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
-
-removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
-removeWith dflags remover f = remover f `catchIO`
- (\e ->
- let msg = if isDoesNotExistError e
- then text "Warning: deleting non-existent" <+> text f
- else text "Warning: exception raised when deleting"
- <+> text f <> colon
- $$ text (show e)
- in debugTraceMsg dflags 2 msg
- )
-
-----------------------------------------------------------------------------
-- Running an external program
@@ -1243,7 +1057,7 @@ runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env =
return (r,())
where
getResponseFile args = do
- fp <- newTempName dflags "rsp"
+ fp <- newTempName dflags TFL_CurrentModule "rsp"
withFile fp WriteMode $ \h -> do
#if defined(mingw32_HOST_OS)
hSetEncoding h latin1
@@ -1431,22 +1245,6 @@ data BuildMessage
| BuildError !SrcLoc !SDoc
| EOF
-traceCmd :: DynFlags -> String -> String -> IO a -> IO a
--- trace the command (at two levels of verbosity)
-traceCmd dflags phase_name cmd_line action
- = do { let verb = verbosity dflags
- ; showPass dflags phase_name
- ; debugTraceMsg dflags 3 (text cmd_line)
- ; case flushErr dflags of
- FlushErr io -> io
-
- -- And run it!
- ; action `catchIO` handle_exn verb
- }
- where
- handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
- ; debugTraceMsg dflags 2 (text "Failed:" <+> text cmd_line <+> text (show exn))
- ; throwGhcExceptionIO (ProgramError (show exn))}
{-
************************************************************************
@@ -1539,12 +1337,6 @@ foreign import WINDOWS_CCONV unsafe "dynamic"
getBaseDir = return Nothing
#endif
-#if defined(mingw32_HOST_OS)
-foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
-#else
-getProcessID :: IO Int
-getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
-#endif
-- Divvy up text stream into lines, taking platform dependent
-- line termination into account.
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 5f81a2ce7c..d502fb8800 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -42,7 +42,7 @@ import GHCi
import GHCi.RemoteTypes
import GHCi.BreakArray
import DynFlags
-import ErrUtils
+import ErrUtils hiding (traceCmd)
import GhcMonad ( modifySession )
import qualified GHC
import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index d4a937c0ef..8ea1c72ac7 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -1110,6 +1110,17 @@ test('MultiLayerModules',
multimod_compile,
['MultiLayerModules', '-v0'])
+test('T13701',
+ [ compiler_stats_num_field('bytes allocated',
+ [(platform('x86_64-apple-darwin'), 2217187888, 10),
+ (wordsize(64), 2511285600, 10),
+ ]),
+ pre_cmd('./genT13701'),
+ extra_files(['genT13701']),
+ ],
+ multimod_compile,
+ ['T13701', '-v0'])
+
test('T13719',
[ compiler_stats_num_field('bytes allocated',
[(wordsize(64), 5187889872, 10),
diff --git a/testsuite/tests/perf/compiler/genT13701 b/testsuite/tests/perf/compiler/genT13701
new file mode 100755
index 0000000000..f2b7c4eab2
--- /dev/null
+++ b/testsuite/tests/perf/compiler/genT13701
@@ -0,0 +1,14 @@
+#!/bin/bash
+# Generate $DEPTH layers of modules with $WIDTH modules on each layer
+# Every module on layer N imports all the modules on layer N-1
+# MultiLayerModules.hs imports all the modules from the last layer
+DEPTH=0
+WIDTH=1000
+ROOT=T13701
+for i in $(seq -w 1 $WIDTH); do
+ echo "module DummyLevel0M$i where" > DummyLevel0M$i.hs;
+done
+echo "module $ROOT where" > "$ROOT.hs"
+for j in $(seq -w 1 $WIDTH); do
+ echo "import DummyLevel${DEPTH}M$j" >> "$ROOT.hs";
+done
View Lorry Controller Status