From: Ian Lynagh Date: Thu, 11 Dec 2008 18:07:39 +0000 (+0000) Subject: Make the lists of files and directories to be cleaned-up non-global X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=5e12e5be4fe676a79669f9a0cb5265e5cd33bebe 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. --- diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 53ace5c..8f7b05c 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 1e405ea..b5cfb23 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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, diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index d1fd9f7..136ab35 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -525,32 +525,30 @@ 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