diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2021-07-19 16:52:06 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-07-19 19:38:59 -0400 |
commit | 58b960d2af0ebfc37104ec68a4df377a074951dd (patch) | |
tree | f0fc5bf672f76ec4f032a07d8d292fb1a6eaddb1 | |
parent | 535123e4f6505a148ccaa536c21282a87c42669c (diff) | |
download | haskell-58b960d2af0ebfc37104ec68a4df377a074951dd.tar.gz |
Make TmpFs independent of DynFlags
This is small step towards #19877. We want to make the Loader/Linker
interface more abstract to be easily reused (i.e. don't pass it
DynFlags) but the system linker uses TmpFs which required a DynFlags
value to get its temp directory. We explicitly pass the temp directory
now. Similarly TmpFs was consulting the DynFlags to decide whether to
clean or: this is now done by the caller in the driver code.
-rw-r--r-- | compiler/GHC.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Driver/CodeOutput.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Driver/Main.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Driver/Make.hs | 26 | ||||
-rw-r--r-- | compiler/GHC/Driver/MakeFile.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Driver/Pipeline.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Driver/Pipeline/Execute.hs | 15 | ||||
-rw-r--r-- | compiler/GHC/Driver/Session.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Linker/ExtraObj.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Linker/Loader.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Linker/Static.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Linker/Windows.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/SysTools/Process.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Splice.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Utils/TmpFs.hs | 48 |
16 files changed, 68 insertions, 60 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index b7dd7dfd35..3405d36c55 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -534,8 +534,9 @@ withCleanupSession ghc = ghc `MC.finally` cleanup let logger = hsc_logger hsc_env let tmpfs = hsc_tmpfs hsc_env liftIO $ do - cleanTempFiles logger tmpfs dflags - cleanTempDirs logger tmpfs dflags + unless (gopt Opt_KeepTmpFiles dflags) $ do + cleanTempFiles logger tmpfs + cleanTempDirs logger tmpfs traverse_ stopInterp (hsc_interp hsc_env) -- exceptions will be blocked while we clean the temporary files, -- so there shouldn't be any difficulty if we receive further diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index 291cae88d5..6108e529af 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -210,7 +210,7 @@ outputForeignStubs outputForeignStubs logger tmpfs dflags unit_state mod location stubs = do let stub_h = mkStubPaths dflags (moduleName mod) location - stub_c <- newTempName logger tmpfs dflags TFL_CurrentModule "c" + stub_c <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c" case stubs of NoStubs -> diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index cb3c82ebd1..523d39e3db 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -437,7 +437,8 @@ hscParse' mod_summary -- - filter out the .hs/.lhs source filename if we have one -- let n_hspp = FilePath.normalise src_filename - srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`)) + TempDir tmp_dir = tmpDir dflags + srcs0 = nub $ filter (not . (tmp_dir `isPrefixOf`)) $ filter (not . (== n_hspp)) $ map FilePath.normalise $ filter (not . isPrefixOf "<") diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 2f03bcebd7..aef6953a30 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -80,7 +80,7 @@ import GHC.Data.StringBuffer import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.Exception ( AsyncException(..), evaluate ) -import GHC.Utils.Monad ( allM ) +import GHC.Utils.Monad ( allM, MonadIO ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain @@ -538,7 +538,7 @@ load' how_much mHscMessage mod_graph = do -- Clean up after ourselves hsc_env1 <- getSession - liftIO $ cleanCurrentModuleTempFiles logger (hsc_tmpfs hsc_env1) dflags + liftIO $ cleanCurrentModuleTempFilesMaybe logger (hsc_tmpfs hsc_env1) dflags -- Issue a warning for the confusing case where the user -- said '-o foo' but we're not going to do any linking. @@ -605,7 +605,7 @@ load' how_much mHscMessage mod_graph = do ] tmpfs <- hsc_tmpfs <$> getSession liftIO $ changeTempFilesLifetime tmpfs TFL_CurrentModule unneeded_temps - liftIO $ cleanCurrentModuleTempFiles logger tmpfs dflags + liftIO $ cleanCurrentModuleTempFilesMaybe logger tmpfs dflags let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) hpt4 @@ -1335,9 +1335,9 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_tmpfs lcl_dflags return (hsc_env'', localize_hsc_env hsc_env'') -- Clean up any intermediate files. - cleanCurrentModuleTempFiles (hsc_logger lcl_hsc_env') - (hsc_tmpfs lcl_hsc_env') - (hsc_dflags lcl_hsc_env') + cleanCurrentModuleTempFilesMaybe (hsc_logger lcl_hsc_env') + (hsc_tmpfs lcl_hsc_env') + (hsc_dflags lcl_hsc_env') return Succeeded where @@ -1435,9 +1435,9 @@ upsweep mHscMessage old_hpt sccs = do hsc_env <- getSession -- Remove unwanted tmp files between compilations - liftIO $ cleanCurrentModuleTempFiles (hsc_logger hsc_env) - (hsc_tmpfs hsc_env) - (hsc_dflags hsc_env) + liftIO $ cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) + (hsc_tmpfs hsc_env) + (hsc_dflags hsc_env) -- Get ready to tie the knot type_env_var <- liftIO $ newIORef emptyNameEnv @@ -2175,7 +2175,7 @@ enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife bcknd , ms_mod `Set.member` needs_codegen_set = do let new_temp_file suf dynsuf = do - tn <- newTempName logger tmpfs dflags staticLife suf + tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf let dyn_tn = tn -<.> dynsuf addFilesToClean tmpfs dynLife [dyn_tn] return tn @@ -2709,3 +2709,9 @@ cyclicModuleErr mss ppr_ms :: ModSummary -> SDoc ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+> (parens (text (msHsFilePath ms))) + + +cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m () +cleanCurrentModuleTempFilesMaybe logger tmpfs dflags = + unless (gopt Opt_KeepTmpFiles dflags) $ + liftIO $ cleanCurrentModuleTempFiles logger tmpfs diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs index 8f53d2f598..8207b37c7b 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -136,7 +136,7 @@ beginMkDependHS :: Logger -> TmpFs -> DynFlags -> IO MkDepFiles beginMkDependHS logger tmpfs dflags = do -- open a new temp file in which to stuff the dependency info -- as we go along. - tmp_file <- newTempName logger tmpfs dflags TFL_CurrentModule "dep" + tmp_file <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "dep" tmp_hdl <- openFile tmp_file WriteMode -- open the makefile diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index cdd22b1388..26d2213a01 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -176,7 +176,7 @@ preprocess hsc_env input_fn mb_input_buf mb_phase = Just input_buf -> do fn <- newTempName (hsc_logger hsc_env) (hsc_tmpfs hsc_env) - (hsc_dflags hsc_env) + (tmpDir (hsc_dflags hsc_env)) TFL_CurrentModule ("buf_" ++ src_suffix pipe_env) hdl <- openBinaryFile fn WriteMode @@ -600,7 +600,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do -- and https://github.com/haskell/cabal/issues/2257 let logger = hsc_logger hsc_env let tmpfs = hsc_tmpfs hsc_env - empty_stub <- newTempName logger tmpfs dflags TFL_CurrentModule "c" + empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c" let home_unit = hsc_home_unit hsc_env src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" writeFile empty_stub (showSDoc dflags (pprCode CStyle src)) diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs index d843f29056..57d491104e 100644 --- a/compiler/GHC/Driver/Pipeline/Execute.hs +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -157,7 +157,10 @@ runMergeForeign _pipe_env hsc_env _location input_fn foreign_os = do else do -- Work around a binutil < 2.31 bug where you can't merge objects if the output file -- is one of the inputs - new_o <- newTempName (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) TFL_CurrentModule "o" + new_o <- newTempName (hsc_logger hsc_env) + (hsc_tmpfs hsc_env) + (tmpDir (hsc_dflags hsc_env)) + TFL_CurrentModule "o" copyFile input_fn new_o let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env @@ -764,8 +767,8 @@ getOutputFilename logger tmpfs stop_phase output basename dflags next_phase mayb Nothing -> panic "SpecificFile: No filename" | keep_this_output = persistent_fn - | Temporary lifetime <- output = newTempName logger tmpfs dflags lifetime suffix - | otherwise = newTempName logger tmpfs dflags TFL_CurrentModule + | Temporary lifetime <- output = newTempName logger tmpfs (tmpDir dflags) lifetime suffix + | otherwise = newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule suffix where hcsuf = hcSuf dflags @@ -926,7 +929,7 @@ doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do pkgs = catMaybes (map (lookupUnit unit_state) uids) mb_macro_include <- if not (null pkgs) && gopt Opt_VersionMacros dflags - then do macro_stub <- newTempName logger tmpfs dflags TFL_CurrentModule "h" + then do macro_stub <- newTempName logger tmpfs (tmpDir 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 @@ -1069,14 +1072,14 @@ joinObjectFiles logger tmpfs dflags o_files output_fn = do if ldIsGnuLd then do - script <- newTempName logger tmpfs dflags TFL_CurrentModule "ldscript" + script <- newTempName logger tmpfs (tmpDir 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 [GHC.SysTools.FileOption "" script] else if toolSettings_ldSupportsFilelist toolSettings' then do - filelist <- newTempName logger tmpfs dflags TFL_CurrentModule "filelist" + filelist <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "filelist" writeFile filelist $ unlines o_files ld_r [GHC.SysTools.Option "-filelist", GHC.SysTools.FileOption "" filelist] diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index b190fe70a9..64a1f16ebb 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -249,6 +249,7 @@ import GHC.Types.SafeHaskell import GHC.Types.Basic ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf ) import qualified GHC.Types.FieldLabel as FieldLabel import GHC.Data.FastString +import GHC.Utils.TmpFs import GHC.Utils.Fingerprint import GHC.Utils.Outputable import GHC.Settings @@ -791,8 +792,8 @@ toolDir :: DynFlags -> Maybe FilePath toolDir dflags = fileSettings_toolDir $ fileSettings dflags topDir :: DynFlags -> FilePath topDir dflags = fileSettings_topDir $ fileSettings dflags -tmpDir :: DynFlags -> String -tmpDir dflags = fileSettings_tmpDir $ fileSettings dflags +tmpDir :: DynFlags -> TempDir +tmpDir dflags = TempDir (fileSettings_tmpDir $ fileSettings dflags) extraGccViaCFlags :: DynFlags -> [String] extraGccViaCFlags dflags = toolSettings_extraGccViaCFlags $ toolSettings dflags globalPackageDatabasePath :: DynFlags -> FilePath diff --git a/compiler/GHC/Linker/ExtraObj.hs b/compiler/GHC/Linker/ExtraObj.hs index 1bc4f4234b..163bccf3fe 100644 --- a/compiler/GHC/Linker/ExtraObj.hs +++ b/compiler/GHC/Linker/ExtraObj.hs @@ -49,8 +49,8 @@ import Data.Maybe mkExtraObj :: Logger -> TmpFs -> DynFlags -> UnitState -> Suffix -> String -> IO FilePath mkExtraObj logger tmpfs dflags unit_state extn xs - = do cFile <- newTempName logger tmpfs dflags TFL_CurrentModule extn - oFile <- newTempName logger tmpfs dflags TFL_GhcSession "o" + = do cFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule extn + oFile <- newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession "o" writeFile cFile xs ccInfo <- liftIO $ getCompilerInfo logger dflags runCc Nothing logger tmpfs dflags diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs index 832d2b0cfd..68484eb288 100644 --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -952,7 +952,7 @@ dynLoadObjs interp hsc_env pls@LoaderState{..} objs = do let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ] let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ] (soFile, libPath , libName) <- - newTempLibName logger tmpfs dflags TFL_CurrentModule (platformSOExt platform) + newTempLibName logger tmpfs (tmpDir dflags) TFL_CurrentModule (platformSOExt platform) let dflags2 = dflags { -- We don't want the original ldInputs in diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs index cfb83f0575..ae7a334f98 100644 --- a/compiler/GHC/Linker/Static.hs +++ b/compiler/GHC/Linker/Static.hs @@ -123,7 +123,7 @@ linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do if gopt Opt_SingleLibFolder dflags then do libs <- getLibs dflags unit_env dep_units - tmpDir <- newTempDir logger tmpfs dflags + tmpDir <- newTempDir logger tmpfs (tmpDir dflags) sequence_ [ copyFile lib (tmpDir </> basename) | (lib, basename) <- libs] return [ "-L" ++ tmpDir ] diff --git a/compiler/GHC/Linker/Windows.hs b/compiler/GHC/Linker/Windows.hs index 8be0802002..a791cdf007 100644 --- a/compiler/GHC/Linker/Windows.hs +++ b/compiler/GHC/Linker/Windows.hs @@ -45,9 +45,9 @@ maybeCreateManifest logger tmpfs dflags exe_filename = do if not (gopt Opt_EmbedManifest dflags) then return [] else do - rc_filename <- newTempName logger tmpfs dflags TFL_CurrentModule "rc" + rc_filename <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "rc" rc_obj_filename <- - newTempName logger tmpfs dflags TFL_GhcSession (objectSuf dflags) + newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession (objectSuf dflags) writeFile rc_filename $ "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index 5373e3d07f..546c270f76 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -206,7 +206,7 @@ cgTopBinding logger tmpfs dflags = \case (lit,decl) = if not isNCG || asString then mkByteStringCLit label str else mkFileEmbedLit label $ unsafePerformIO $ do - bFile <- newTempName logger tmpfs dflags TFL_CurrentModule ".dat" + bFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule ".dat" BS.writeFile bFile str return bFile emitDecl decl diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs index 6cb322363d..63ff2c8294 100644 --- a/compiler/GHC/SysTools/Process.hs +++ b/compiler/GHC/SysTools/Process.hs @@ -168,7 +168,7 @@ runSomethingResponseFile logger tmpfs dflags filter_fn phase_name pgm args mb_en return (r,()) where getResponseFile args = do - fp <- newTempName logger tmpfs dflags TFL_CurrentModule "rsp" + fp <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "rsp" withFile fp WriteMode $ \h -> do #if defined(mingw32_HOST_OS) hSetEncoding h latin1 diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 4a5c71a85c..bcb77326e2 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -1211,7 +1211,7 @@ instance TH.Quasi TcM where dflags <- getDynFlags logger <- getLogger tmpfs <- hsc_tmpfs <$> getTopEnv - liftIO $ newTempName logger tmpfs dflags TFL_GhcSession suffix + liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix qAddTopDecls thds = do l <- getSrcSpanM diff --git a/compiler/GHC/Utils/TmpFs.hs b/compiler/GHC/Utils/TmpFs.hs index 2244a898ff..68284097d1 100644 --- a/compiler/GHC/Utils/TmpFs.hs +++ b/compiler/GHC/Utils/TmpFs.hs @@ -9,6 +9,7 @@ module GHC.Utils.TmpFs , FilesToClean(..) , emptyFilesToClean , TempFileLifetime(..) + , TempDir (..) , cleanTempDirs , cleanTempFiles , cleanCurrentModuleTempFiles @@ -24,7 +25,6 @@ where import GHC.Prelude -import GHC.Driver.Session import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Logger @@ -32,7 +32,6 @@ import GHC.Utils.Misc import GHC.Utils.Exception as Exception import GHC.Driver.Phases -import Control.Monad import Data.List (partition) import qualified Data.Set as Set import Data.Set (Set) @@ -92,6 +91,7 @@ data TempFileLifetime -- runGhc(T) deriving (Show) +newtype TempDir = TempDir FilePath -- | An empty FilesToClean emptyFilesToClean :: FilesToClean @@ -135,19 +135,17 @@ mergeTmpFsInto src dst = do src_files <- atomicModifyIORef' (tmp_files_to_clean src) (\s -> (emptyFilesToClean, s)) atomicModifyIORef' (tmp_files_to_clean dst) (\s -> (mergeFilesToClean src_files s, ())) -cleanTempDirs :: Logger -> TmpFs -> DynFlags -> IO () -cleanTempDirs logger tmpfs dflags - = unless (gopt Opt_KeepTmpFiles dflags) - $ mask_ +cleanTempDirs :: Logger -> TmpFs -> IO () +cleanTempDirs logger tmpfs + = mask_ $ do let ref = tmp_dirs_to_clean tmpfs ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds) removeTmpDirs logger (Map.elems ds) -- | Delete all files in @tmp_files_to_clean@. -cleanTempFiles :: Logger -> TmpFs -> DynFlags -> IO () -cleanTempFiles logger tmpfs dflags - = unless (gopt Opt_KeepTmpFiles dflags) - $ mask_ +cleanTempFiles :: Logger -> TmpFs -> IO () +cleanTempFiles logger tmpfs + = mask_ $ do let ref = tmp_files_to_clean tmpfs to_delete <- atomicModifyIORef' ref $ \FilesToClean @@ -161,10 +159,9 @@ cleanTempFiles logger tmpfs dflags -- TFL_CurrentModule. -- If a file must be cleaned eventually, but must survive a -- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession. -cleanCurrentModuleTempFiles :: Logger -> TmpFs -> DynFlags -> IO () -cleanCurrentModuleTempFiles logger tmpfs dflags - = unless (gopt Opt_KeepTmpFiles dflags) - $ mask_ +cleanCurrentModuleTempFiles :: Logger -> TmpFs -> IO () +cleanCurrentModuleTempFiles logger tmpfs + = mask_ $ do let ref = tmp_files_to_clean tmpfs to_delete <- atomicModifyIORef' ref $ \ftc@FilesToClean{ftcCurrentModule = cm_files} -> @@ -212,9 +209,9 @@ newTempSuffix tmpfs = atomicModifyIORef' (tmp_next_suffix tmpfs) $ \n -> (n+1,n) -- Find a temporary name that doesn't already exist. -newTempName :: Logger -> TmpFs -> DynFlags -> TempFileLifetime -> Suffix -> IO FilePath -newTempName logger tmpfs dflags lifetime extn - = do d <- getTempDir logger tmpfs dflags +newTempName :: Logger -> TmpFs -> TempDir -> TempFileLifetime -> Suffix -> IO FilePath +newTempName logger tmpfs tmp_dir lifetime extn + = do d <- getTempDir logger tmpfs tmp_dir findTempName (d </> "ghc_") -- See Note [Deterministic base name] where findTempName :: FilePath -> IO FilePath @@ -227,9 +224,9 @@ newTempName logger tmpfs dflags lifetime extn addFilesToClean tmpfs lifetime [filename] return filename -newTempDir :: Logger -> TmpFs -> DynFlags -> IO FilePath -newTempDir logger tmpfs dflags - = do d <- getTempDir logger tmpfs dflags +newTempDir :: Logger -> TmpFs -> TempDir -> IO FilePath +newTempDir logger tmpfs tmp_dir + = do d <- getTempDir logger tmpfs tmp_dir findTempDir (d </> "ghc_") where findTempDir :: FilePath -> IO FilePath @@ -242,10 +239,10 @@ newTempDir logger tmpfs dflags -- see mkTempDir below; this is wrong: -> consIORef (tmp_dirs_to_clean tmpfs) filename return filename -newTempLibName :: Logger -> TmpFs -> DynFlags -> TempFileLifetime -> Suffix +newTempLibName :: Logger -> TmpFs -> TempDir -> TempFileLifetime -> Suffix -> IO (FilePath, FilePath, String) -newTempLibName logger tmpfs dflags lifetime extn - = do d <- getTempDir logger tmpfs dflags +newTempLibName logger tmpfs tmp_dir lifetime extn + = do d <- getTempDir logger tmpfs tmp_dir findTempName d ("ghc_") where findTempName :: FilePath -> String -> IO (FilePath, FilePath, String) @@ -262,8 +259,8 @@ newTempLibName logger tmpfs dflags lifetime extn -- Return our temporary directory within tmp_dir, creating one if we -- don't have one yet. -getTempDir :: Logger -> TmpFs -> DynFlags -> IO FilePath -getTempDir logger tmpfs dflags = do +getTempDir :: Logger -> TmpFs -> TempDir -> IO FilePath +getTempDir logger tmpfs (TempDir tmp_dir) = do mapping <- readIORef dir_ref case Map.lookup tmp_dir mapping of Nothing -> do @@ -272,7 +269,6 @@ getTempDir logger tmpfs dflags = do mask_ $ mkTempDir prefix Just dir -> return dir where - tmp_dir = tmpDir dflags dir_ref = tmp_dirs_to_clean tmpfs mkTempDir :: FilePath -> IO FilePath |