Commit 5e12e5be authored by Ian Lynagh's avatar Ian Lynagh

Make the lists of files and directories to be cleaned-up non-global

They still need to be stored in IORefs, as the exception handler needs
to know what they all are.
parent 3db6d1b8
......@@ -1071,8 +1071,8 @@ runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe
dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) }
-- Remember to delete all these files
addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s"
| n <- [1..n_files]]
addFilesToClean dflags' [ split_s_prefix ++ "__" ++ show n ++ ".s"
| n <- [1..n_files]]
return (SplitAs, dflags', maybe_loc, "**splitmangle**")
-- we don't use the filename
......
......@@ -84,10 +84,11 @@ import Util
import Maybes ( orElse )
import SrcLoc
import FastString
import FiniteMap
import Outputable
import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage )
import Data.IORef ( readIORef )
import Data.IORef
import Control.Monad ( when )
import Data.Char
......@@ -433,6 +434,12 @@ data DynFlags = DynFlags {
pkgDatabase :: Maybe (UniqFM PackageConfig),
pkgState :: PackageState,
-- Temporary files
-- These have to be IORefs, because the defaultCleanupHandler needs to
-- know what to clean when an exception happens
filesToClean :: IORef [FilePath],
dirsToClean :: IORef (FiniteMap FilePath FilePath),
-- hsc dynamic flags
flags :: [DynFlag],
......@@ -539,10 +546,14 @@ initDynFlags dflags = do
ways <- readIORef v_Ways
build_tag <- readIORef v_Build_tag
rts_build_tag <- readIORef v_RTS_Build_tag
refFilesToClean <- newIORef []
refDirsToClean <- newIORef emptyFM
return dflags{
wayNames = ways,
buildTag = build_tag,
rtsBuildTag = rts_build_tag
rtsBuildTag = rts_build_tag,
filesToClean = refFilesToClean,
dirsToClean = refDirsToClean
}
-- | The normal 'DynFlags'. Note that they is not suitable for use in this form
......@@ -641,6 +652,8 @@ defaultDynFlags =
depExcludeMods = [],
depSuffixes = [],
-- end of ghc -M values
filesToClean = panic "defaultDynFlags: No filesToClean",
dirsToClean = panic "defaultDynFlags: No dirsToClean",
haddockOptions = Nothing,
flags = [
Opt_AutoLinkPackages,
......
......@@ -524,33 +524,31 @@ getExtraViaCOpts dflags = do
%* *
%************************************************************************
\begin{code}
GLOBAL_VAR(v_FilesToClean, [], [String] )
GLOBAL_VAR(v_DirsToClean, emptyFM, FiniteMap FilePath FilePath )
\end{code}
\begin{code}
cleanTempDirs :: DynFlags -> IO ()
cleanTempDirs dflags
= unless (dopt Opt_KeepTmpFiles dflags)
$ do ds <- readIORef v_DirsToClean
$ do let ref = dirsToClean dflags
ds <- readIORef ref
removeTmpDirs dflags (eltsFM ds)
writeIORef v_DirsToClean emptyFM
writeIORef ref emptyFM
cleanTempFiles :: DynFlags -> IO ()
cleanTempFiles dflags
= unless (dopt Opt_KeepTmpFiles dflags)
$ do fs <- readIORef v_FilesToClean
$ do let ref = filesToClean dflags
fs <- readIORef ref
removeTmpFiles dflags fs
writeIORef v_FilesToClean []
writeIORef ref []
cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
cleanTempFilesExcept dflags dont_delete
= unless (dopt Opt_KeepTmpFiles dflags)
$ do files <- readIORef v_FilesToClean
$ do let ref = filesToClean dflags
files <- readIORef ref
let (to_keep, to_delete) = partition (`elem` dont_delete) files
removeTmpFiles dflags to_delete
writeIORef v_FilesToClean to_keep
writeIORef ref to_keep
-- find a temporary name that doesn't already exist.
......@@ -565,14 +563,16 @@ newTempName dflags extn
= do let filename = (prefix ++ show x) <.> extn
b <- doesFileExist filename
if b then findTempName prefix (x+1)
else do consIORef v_FilesToClean filename -- clean it up later
else do -- clean it up later
consIORef (filesToClean dflags) filename
return filename
-- return our temporary directory within tmp_dir, creating one if we
-- don't have one yet
getTempDir :: DynFlags -> IO FilePath
getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
= do mapping <- readIORef v_DirsToClean
= do let ref = dirsToClean dflags
mapping <- readIORef ref
case lookupFM mapping tmp_dir of
Nothing ->
do x <- getProcessID
......@@ -583,7 +583,7 @@ getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
= let dirname = prefix ++ show x
in do createDirectory dirname
let mapping' = addToFM mapping tmp_dir dirname
writeIORef v_DirsToClean mapping'
writeIORef ref mapping'
debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname)
return dirname
`IO.catch` \e ->
......@@ -593,9 +593,9 @@ getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
mkTempDir 0
Just d -> return d
addFilesToClean :: [FilePath] -> IO ()
addFilesToClean :: DynFlags -> [FilePath] -> IO ()
-- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
addFilesToClean dflags files = mapM_ (consIORef (filesToClean dflags)) files
removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
removeTmpDirs dflags ds
......
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