Commit 3ee3822c authored by Douglas Wilson's avatar Douglas Wilson Committed by Ben Gamari
Browse files

Refactor temp files cleanup

Remove filesToNotIntermediateClean from DynFlags, create a data type
FilesToClean, and change filesToClean in DynFlags to be a FilesToClean.

Modify SysTools.newTempName and the Temporary constructor of
PipelineMonad.PipelineOutput to take a TempFileLifetime, which specifies
whether a temp file should live until the end of GhcMonad.withSession,
or until the next time cleanIntermediateTempFiles is called.

These changes allow the cleaning of intermediate files in GhcMake to be
much more efficient.

HscTypes.hptObjs is removed as it is no longer used.

A new performance test T13701 is added, which passes both with and
without -keep-tmp-files.  The test fails by 25% without the patch, and
passes when -keep-tmp-files is added.

Note that there are still at two hotspots caused by
algorithms quadratic in the number of modules, however neither of them
allocate. They are:

* DriverPipeline.compileOne'.needsLinker
* GhcMake.getModLoop

DriverPipeline.compileOne'.needsLinker is changed slightly to improve
the situation.

I don't like adding these Types to DynFlags, but they need to be seen by
Dynflags, SysTools and PipelineMonad. The alternative seems to be to
create a new module.

Reviewers: austin, hvr, bgamari, dfeuer, niteria, simonmar, erikd

Reviewed By: simonmar

Subscribers: rwbarton, thomie

GHC Trac Issues: #13701

Differential Revision: https://phabricator.haskell.org/D3620
parent cd8f4b99
......@@ -165,6 +165,7 @@ Library
vectorise
Exposed-Modules:
FileCleanup
DriverBkp
BkpSyn
NameShape
......
......@@ -478,6 +478,7 @@ compiler_stage2_dll0_MODULES = \
FastString \
FastStringEnv \
FieldLabel \
FileCleanup \
Fingerprint \
FiniteMap \
ForeignCall \
......
......@@ -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 }
......
......@@ -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
......
......@@ -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
......@@ -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
......
......@@ -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
......
......@@ -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
......@@ -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))}
{-# 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