import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) )
import HscTypes
import DynFlags
-import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept )
+import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
+ cleanTempDirs )
import Module
import UniqFM
import PackageConfig ( PackageId )
-- handling, but still get the ordinary cleanup behaviour.
defaultCleanupHandler :: DynFlags -> IO a -> IO a
defaultCleanupHandler dflags inner =
- -- make sure we clean up after ourselves
- later (unless (dopt Opt_KeepTmpFiles dflags) $
- cleanTempFiles dflags)
- -- exceptions will be blocked while we clean the temporary files,
- -- so there shouldn't be any difficulty if we receive further
- -- signals.
- inner
+ -- make sure we clean up after ourselves
+ later (unless (dopt Opt_KeepTmpFiles dflags) $
+ do cleanTempFiles dflags
+ cleanTempDirs dflags
+ )
+ -- exceptions will be blocked while we clean the temporary files,
+ -- so there shouldn't be any difficulty if we receive further
+ -- signals.
+ inner
-- | Initialises GHC. This must be done /once/ only. Takes the
-- Temporary-file management
setTmpDir,
newTempName,
- cleanTempFiles, cleanTempFilesExcept,
+ cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
addFilesToClean,
-- System interface
import System ( ExitCode(..), getEnv, system )
import IO ( try, catch, hGetContents,
openFile, hPutStr, hClose, hFlush, IOMode(..),
- stderr, ioError, isDoesNotExistError )
-import Directory ( doesFileExist, removeFile )
+ stderr, ioError, isDoesNotExistError,
+ isAlreadyExistsError )
+import Directory ( doesFileExist, removeFile,
+ createDirectory, removeDirectory )
import Maybe ( isJust )
import List ( partition )
+import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, eltsFM )
-- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
-- lines on mingw32, so we disallow it now.
\begin{code}
GLOBAL_VAR(v_FilesToClean, [], [String] )
+GLOBAL_VAR(v_DirsToClean, emptyFM, FiniteMap FilePath FilePath )
\end{code}
\begin{code}
+cleanTempDirs :: DynFlags -> IO ()
+cleanTempDirs dflags
+ = do ds <- readIORef v_DirsToClean
+ removeTmpDirs dflags (eltsFM ds)
+ writeIORef v_DirsToClean emptyFM
+
cleanTempFiles :: DynFlags -> IO ()
cleanTempFiles dflags
= do fs <- readIORef v_FilesToClean
-- find a temporary name that doesn't already exist.
newTempName :: DynFlags -> Suffix -> IO FilePath
-newTempName DynFlags{tmpDir=tmp_dir} extn
- = do x <- getProcessID
- findTempName (tmp_dir ++ "/ghc" ++ show x ++ "_") 0
+newTempName dflags extn
+ = do d <- getTempDir dflags
+ x <- getProcessID
+ findTempName (d ++ "/ghc" ++ show x ++ "_") 0
where
findTempName prefix x
= do let filename = (prefix ++ show x) `joinFileExt` extn
else do consIORef v_FilesToClean filename -- clean it up later
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
+ case lookupFM mapping tmp_dir of
+ Nothing ->
+ do x <- getProcessID
+ let prefix = tmp_dir ++ "/ghc" ++ show x ++ "_"
+ mkTempDir x
+ = let dirname = prefix ++ show x
+ in do createDirectory dirname
+ let mapping' = addToFM mapping tmp_dir dirname
+ writeIORef v_DirsToClean mapping'
+ debugTraceMsg dflags 2 (ptext SLIT("Created temporary directory:") <+> text dirname)
+ return dirname
+ `IO.catch` \e ->
+ if isAlreadyExistsError e
+ then mkTempDir (x+1)
+ else ioError e
+ mkTempDir 0
+ Just d -> return d
+
addFilesToClean :: [FilePath] -> IO ()
-- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
+removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
+removeTmpDirs dflags ds
+ = traceCmd dflags "Deleting temp dirs"
+ ("Deleting: " ++ unwords ds)
+ (mapM_ rmdir ds)
+ where
+ rmdir d = removeDirectory d `IO.catch`
+ (\_ignored ->
+ debugTraceMsg dflags 2 (ptext SLIT("Warning: deleting") <+> text d <+> ptext SLIT("raised exception"))
+ )
+
removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
removeTmpFiles dflags fs
= warnNon $