diff options
22 files changed, 439 insertions, 329 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 9e247012cf..5a36987817 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -351,7 +351,7 @@ import GHC.Tc.Module import GHC.Tc.Utils.Instantiate import GHC.Tc.Instance.Family -import GHC.SysTools.FileCleanup +import GHC.Utils.TmpFs import GHC.SysTools import GHC.SysTools.BaseDir @@ -533,9 +533,10 @@ withCleanupSession ghc = ghc `MC.finally` cleanup hsc_env <- getSession let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env + let tmpfs = hsc_tmpfs hsc_env liftIO $ do - cleanTempFiles logger dflags - cleanTempDirs logger dflags + cleanTempFiles logger tmpfs dflags + cleanTempDirs logger tmpfs dflags stopInterp hsc_env -- shut down the IServ -- 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 b459b7b447..8c990b16cb 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -36,7 +36,7 @@ import qualified GHC.Data.ShortText as ST import GHC.Data.Stream ( Stream ) import qualified GHC.Data.Stream as Stream -import GHC.SysTools.FileCleanup +import GHC.Utils.TmpFs import GHC.Utils.Error @@ -66,23 +66,24 @@ import System.IO ************************************************************************ -} -codeOutput :: Logger - -> DynFlags - -> UnitState - -> Module - -> FilePath - -> ModLocation - -> (a -> ForeignStubs) - -> [(ForeignSrcLang, FilePath)] - -- ^ additional files to be compiled with the C compiler - -> [UnitId] - -> Stream IO RawCmmGroup a -- Compiled C-- - -> IO (FilePath, - (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}), - [(ForeignSrcLang, FilePath)]{-foreign_fps-}, - a) - -codeOutput logger dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps +codeOutput + :: Logger + -> TmpFs + -> DynFlags + -> UnitState + -> Module + -> FilePath + -> ModLocation + -> (a -> ForeignStubs) + -> [(ForeignSrcLang, FilePath)] + -- ^ additional files to be compiled with the C compiler + -> [UnitId] + -> Stream IO RawCmmGroup a -- Compiled C-- + -> IO (FilePath, + (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}), + [(ForeignSrcLang, FilePath)]{-foreign_fps-}, + a) +codeOutput logger tmpfs dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps cmm_stream = do { @@ -117,7 +118,7 @@ codeOutput logger dflags unit_state this_mod filenm location genForeignStubs for Interpreter -> panic "codeOutput: Interpreter" NoBackend -> panic "codeOutput: NoBackend" ; let stubs = genForeignStubs a - ; stubs_exist <- outputForeignStubs logger dflags unit_state this_mod location stubs + ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs ; return (filenm, stubs_exist, foreign_fps, a) } @@ -198,13 +199,20 @@ outputLlvm logger dflags filenm cmm_stream = ************************************************************************ -} -outputForeignStubs :: Logger -> DynFlags -> UnitState -> Module -> ModLocation -> ForeignStubs - -> IO (Bool, -- Header file created - Maybe FilePath) -- C file created -outputForeignStubs logger dflags unit_state mod location stubs +outputForeignStubs + :: Logger + -> TmpFs + -> DynFlags + -> UnitState + -> Module + -> ModLocation + -> ForeignStubs + -> IO (Bool, -- Header file created + Maybe FilePath) -- C file created +outputForeignStubs logger tmpfs dflags unit_state mod location stubs = do let stub_h = mkStubPaths dflags (moduleName mod) location - stub_c <- newTempName logger dflags TFL_CurrentModule "c" + stub_c <- newTempName logger tmpfs dflags TFL_CurrentModule "c" case stubs of NoStubs -> diff --git a/compiler/GHC/Driver/Env/Types.hs b/compiler/GHC/Driver/Env/Types.hs index e541dfe544..23282eab27 100644 --- a/compiler/GHC/Driver/Env/Types.hs +++ b/compiler/GHC/Driver/Env/Types.hs @@ -22,6 +22,7 @@ import GHC.Unit.Env import GHC.Unit.State import GHC.Unit.Types import GHC.Utils.Logger +import GHC.Utils.TmpFs import {-# SOURCE #-} GHC.Driver.Plugins import Control.Monad ( ap ) @@ -159,5 +160,8 @@ data HscEnv , hsc_hooks :: !Hooks -- ^ Hooks + + , hsc_tmpfs :: !TmpFs + -- ^ Temporary files } diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index d3695177d3..5be42094a0 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -207,6 +207,7 @@ import GHC.Utils.Outputable import GHC.Utils.Exception import GHC.Utils.Misc import GHC.Utils.Logger +import GHC.Utils.TmpFs import GHC.Data.FastString import GHC.Data.Bag @@ -248,6 +249,7 @@ newHscEnv dflags = do fc_var <- newIORef emptyInstalledModuleEnv emptyLoader <- uninitializedLoader logger <- initLogger + tmpfs <- initTmpFs -- FIXME: it's sad that we have so many "unitialized" fields filled with -- empty stuff or lazy panics. We should have two kinds of HscEnv -- (initialized or not) instead and less fields that are mutable over time. @@ -268,6 +270,7 @@ newHscEnv dflags = do , hsc_static_plugins = [] , hsc_unit_dbs = Nothing , hsc_hooks = emptyHooks + , hsc_tmpfs = tmpfs } -- ----------------------------------------------------------------------------- @@ -1528,6 +1531,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env hooks = hsc_hooks hsc_env + tmpfs = hsc_tmpfs hsc_env data_tycons = filter isDataTyCon tycons -- cg_tycons includes newtypes, for the benefit of External Core, -- but we don't generate any code for newtypes @@ -1581,7 +1585,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos) <- {-# SCC "codeOutput" #-} - codeOutput logger dflags (hsc_units hsc_env) this_mod output_filename location + codeOutput logger tmpfs dflags (hsc_units hsc_env) this_mod output_filename location foreign_stubs foreign_files dependencies rawcmms1 return (output_filename, stub_c_exists, foreign_fps, cg_infos) @@ -1593,6 +1597,7 @@ hscInteractive :: HscEnv hscInteractive hsc_env cgguts location = do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env + let tmpfs = hsc_tmpfs hsc_env let CgGuts{ -- This is the last use of the ModGuts in a compilation. -- From now on, we just use the bits we need. cg_module = this_mod, @@ -1615,7 +1620,7 @@ hscInteractive hsc_env cgguts location = do comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks ------------------ Create f-x-dynamic C-side stuff ----- (_istub_h_exists, istub_c_exists) - <- outputForeignStubs logger dflags (hsc_units hsc_env) this_mod location foreign_stubs + <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod location foreign_stubs return (istub_c_exists, comp_bc, spt_entries) ------------------------------ @@ -1625,6 +1630,7 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let hooks = hsc_hooks hsc_env + let tmpfs = hsc_tmpfs hsc_env home_unit = hsc_home_unit hsc_env platform = targetPlatform dflags -- Make up a module name to give the NCG. We can't pass bottom here @@ -1661,7 +1667,7 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do in NoStubs `appendStubC` ip_init (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos) - <- codeOutput logger dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] [] + <- codeOutput logger tmpfs dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] [] rawCmms return stub_c_exists where @@ -1703,14 +1709,15 @@ doCodeGen hsc_env this_mod denv data_tycons let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let hooks = hsc_hooks hsc_env - platform = targetPlatform dflags + let tmpfs = hsc_tmpfs hsc_env + let platform = targetPlatform dflags let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds dumpIfSet_dyn logger dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs) let stg_to_cmm = case stgToCmmHook hooks of - Nothing -> StgToCmm.codeGen logger + Nothing -> StgToCmm.codeGen logger tmpfs Just h -> h let cmm_stream :: Stream IO CmmGroup (CStub, ModuleLFInfos) diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index f13d13b198..bd885d9042 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -83,7 +83,7 @@ import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Error import GHC.Utils.Logger -import GHC.SysTools.FileCleanup +import GHC.Utils.TmpFs import GHC.Types.Basic import GHC.Types.Target @@ -568,8 +568,6 @@ load' how_much mHscMessage mod_graph = do -- an unstable module (#7231). mg = fmap (fmap ModuleNode) stable_mg ++ unstable_mg - -- clean up between compilations - let cleanup hsc_env = cleanCurrentModuleTempFiles (hsc_logger hsc_env) (hsc_dflags hsc_env) liftIO $ debugTraceMsg logger dflags 2 (hang (text "Ready for upsweep") 2 (ppr mg)) @@ -581,7 +579,7 @@ load' how_much mHscMessage mod_graph = do setSession hsc_env{ hsc_HPT = emptyHomePackageTable } (upsweep_ok, modsUpswept) <- withDeferredDiagnostics $ - upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg + upsweep_fn mHscMessage pruned_hpt stable_mods mg -- Make modsDone be the summaries for each home module now -- available; this should equal the domain of hpt3. @@ -601,7 +599,7 @@ load' how_much mHscMessage mod_graph = do -- Clean up after ourselves hsc_env1 <- getSession - liftIO $ cleanCurrentModuleTempFiles logger dflags + liftIO $ cleanCurrentModuleTempFiles 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. @@ -620,6 +618,7 @@ load' how_much mHscMessage mod_graph = do hsc_env <- getSession linkresult <- liftIO $ link (ghcLink dflags) logger + (hsc_tmpfs hsc_env) (hsc_hooks hsc_env) dflags (hsc_unit_env hsc_env) @@ -665,9 +664,9 @@ load' how_much mHscMessage mod_graph = do lookupHpt hpt4 (moduleName ms_mod) >>= hm_linkable ] - liftIO $ - changeTempFilesLifetime dflags TFL_CurrentModule unneeded_temps - liftIO $ cleanCurrentModuleTempFiles logger dflags + tmpfs <- hsc_tmpfs <$> getSession + liftIO $ changeTempFilesLifetime tmpfs TFL_CurrentModule unneeded_temps + liftIO $ cleanCurrentModuleTempFiles logger tmpfs dflags let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) hpt4 @@ -686,6 +685,7 @@ load' how_much mHscMessage mod_graph = do hsc_env <- getSession linkresult <- liftIO $ link (ghcLink dflags) logger + (hsc_tmpfs hsc_env) (hsc_hooks hsc_env) dflags (hsc_unit_env hsc_env) @@ -1067,14 +1067,14 @@ parUpsweep -> Maybe Messager -> HomePackageTable -> StableModules - -> (HscEnv -> IO ()) -> [SCC ModuleGraphNode] -> m (SuccessFlag, [ModuleGraphNode]) -parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do +parUpsweep n_jobs mHscMessage old_hpt stable_mods sccs = do hsc_env <- getSession let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env + let tmpfs = hsc_tmpfs hsc_env -- The bits of shared state we'll be using: @@ -1176,18 +1176,15 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do -- deal with synchronously printing these messages. let lcl_logger = pushLogHook (const (parLogAction log_queue)) thread_safe_logger - -- - -- Use a local filesToClean var so that we can clean up - -- intermediate files in a timely fashion (as soon as - -- compilation for that module is finished) without having to - -- worry about accidentally deleting a simultaneous compile's - -- important files. - lcl_files_to_clean <- newIORef emptyFilesToClean - let lcl_dflags = dflags { filesToClean = lcl_files_to_clean } + -- Use a local TmpFs so that we can clean up intermediate files + -- in a timely fashion (as soon as compilation for that module + -- is finished) without having to worry about accidentally + -- deleting a simultaneous compile's important files. + lcl_tmpfs <- forkTmpFsFrom tmpfs -- Unmask asynchronous exceptions and perform the thread-local -- work to compile the module (see parUpsweep_one). - m_res <- MC.try $ unmask $ prettyPrintGhcErrors lcl_dflags $ + m_res <- MC.try $ unmask $ prettyPrintGhcErrors dflags $ case mod of InstantiationNode iuid -> do hsc_env <- readMVar hsc_env_var @@ -1195,8 +1192,8 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do pure Succeeded ModuleNode ems -> parUpsweep_one (emsModSummary ems) home_mod_map comp_graph_loops - lcl_logger lcl_dflags (hsc_home_unit hsc_env) - mHscMessage cleanup + lcl_logger lcl_tmpfs dflags (hsc_home_unit hsc_env) + mHscMessage par_sem hsc_env_var old_hpt_var stable_mods mod_idx (length sccs) @@ -1208,7 +1205,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do -- interrupt, and the user doesn't have to be informed -- about that. when (fromException exc /= Just ThreadKilled) - (errorMsg lcl_logger lcl_dflags (text (show exc))) + (errorMsg lcl_logger dflags (text (show exc))) return Failed -- Populate the result MVar. @@ -1220,13 +1217,8 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do writeLogQueue log_queue Nothing -- Add the remaining files that weren't cleaned up to the - -- global filesToClean ref, for cleanup later. - FilesToClean - { ftcCurrentModule = cm_files - , ftcGhcSession = gs_files - } <- readIORef (filesToClean lcl_dflags) - addFilesToClean dflags TFL_CurrentModule $ Set.toList cm_files - addFilesToClean dflags TFL_GhcSession $ Set.toList gs_files + -- global TmpFs, for cleanup later. + mergeTmpFsInto lcl_tmpfs tmpfs -- Kill all the workers, masking interrupts (since killThread is -- interruptible). XXX: This is not ideal. @@ -1298,14 +1290,14 @@ parUpsweep_one -- ^ The list of all module loops within the compilation graph. -> Logger -- ^ The thread-local Logger + -> TmpFs + -- ^ The thread-local TmpFs -> DynFlags -- ^ The thread-local DynFlags -> HomeUnit -- ^ The home-unit -> Maybe Messager -- ^ The messager - -> (HscEnv -> IO ()) - -- ^ The callback for cleaning up intermediate files -> QSem -- ^ The semaphore for limiting the number of simultaneous compiles -> MVar HscEnv @@ -1320,7 +1312,7 @@ parUpsweep_one -- ^ The total number of modules -> IO SuccessFlag -- ^ The result of this compile -parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_dflags home_unit mHscMessage cleanup par_sem +parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_tmpfs lcl_dflags home_unit mHscMessage par_sem hsc_env_var old_hpt_var stable_mods mod_index num_mods = do let this_build_mod = mkBuildModule0 mod @@ -1430,9 +1422,7 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_dflags home_unit let withSem sem = MC.bracket_ (waitQSem sem) (signalQSem sem) mb_mod_info <- withSem par_sem $ handleSourceError (\err -> do logg err; return Nothing) $ do - -- Have the ModSummary and HscEnv point to our local log_action - -- and filesToClean var. - let lcl_mod = localize_mod mod + -- Have the HscEnv point to our local logger and tmpfs. let lcl_hsc_env = localize_hsc_env hsc_env -- Re-typecheck the loop @@ -1440,7 +1430,7 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_dflags home_unit -- we close a recursive module loop, see bug #12035. type_env_var <- liftIO $ newIORef emptyNameEnv let lcl_hsc_env' = lcl_hsc_env { hsc_type_env_var = - Just (ms_mod lcl_mod, type_env_var) } + Just (ms_mod mod, type_env_var) } lcl_hsc_env'' <- case finish_loop of Nothing -> return lcl_hsc_env' -- In the non-parallel case, the retypecheck prior to @@ -1454,7 +1444,7 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_dflags home_unit -- Compile the module. mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods - lcl_mod mod_index num_mods + mod mod_index num_mods return (Just mod_info) case mb_mod_info of @@ -1483,18 +1473,16 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_dflags home_unit return (hsc_env'', localize_hsc_env hsc_env'') -- Clean up any intermediate files. - cleanup lcl_hsc_env' + cleanCurrentModuleTempFiles (hsc_logger lcl_hsc_env') + (hsc_tmpfs lcl_hsc_env') + (hsc_dflags lcl_hsc_env') return Succeeded where - localize_mod mod - = mod { ms_hspp_opts = (ms_hspp_opts mod) - { filesToClean = filesToClean lcl_dflags } } - localize_hsc_env hsc_env = hsc_env { hsc_logger = lcl_logger - , hsc_dflags = (hsc_dflags hsc_env) - { filesToClean = filesToClean lcl_dflags } } + , hsc_tmpfs = lcl_tmpfs + } -- ----------------------------------------------------------------------------- -- @@ -1510,7 +1498,6 @@ upsweep => Maybe Messager -> HomePackageTable -- ^ HPT from last time round (pruned) -> StableModules -- ^ stable modules (see checkStability) - -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files -> [SCC ModuleGraphNode] -- ^ Mods to do (the worklist) -> m (SuccessFlag, [ModuleGraphNode]) @@ -1520,7 +1507,7 @@ upsweep -- 2. The 'HscEnv' in the monad has an updated HPT -- 3. A list of modules which succeeded loading. -upsweep mHscMessage old_hpt stable_mods cleanup sccs = do +upsweep mHscMessage old_hpt stable_mods sccs = do (res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs) return (res, reverse $ mgModSummaries' done) where @@ -1588,7 +1575,9 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do hsc_env <- getSession -- Remove unwanted tmp files between compilations - liftIO (cleanup hsc_env) + liftIO $ cleanCurrentModuleTempFiles (hsc_logger hsc_env) + (hsc_tmpfs hsc_env) + (hsc_dflags hsc_env) -- Get ready to tie the knot type_env_var <- liftIO $ newIORef emptyNameEnv @@ -2274,10 +2263,11 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots -- otherwise those modules will fail to compile. -- See Note [-fno-code mode] #8025 let default_backend = platformDefaultBackend (targetPlatform dflags) - home_unit = hsc_home_unit hsc_env + let home_unit = hsc_home_unit hsc_env + let tmpfs = hsc_tmpfs hsc_env map1 <- case backend dflags of - NoBackend -> enableCodeGenForTH logger home_unit default_backend map0 - Interpreter -> enableCodeGenForUnboxedTuplesOrSums logger default_backend map0 + NoBackend -> enableCodeGenForTH logger tmpfs home_unit default_backend map0 + Interpreter -> enableCodeGenForUnboxedTuplesOrSums logger tmpfs default_backend map0 _ -> return map0 if null errs then pure $ concat $ modNodeMapElems map1 @@ -2372,12 +2362,13 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots -- See Note [-fno-code mode] enableCodeGenForTH :: Logger + -> TmpFs -> HomeUnit -> Backend -> ModNodeMap [Either ErrorMessages ExtendedModSummary] -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary]) -enableCodeGenForTH logger home_unit = - enableCodeGenWhen logger condition should_modify TFL_CurrentModule TFL_GhcSession +enableCodeGenForTH logger tmpfs home_unit = + enableCodeGenWhen logger tmpfs condition should_modify TFL_CurrentModule TFL_GhcSession where condition = isTemplateHaskellOrQQNonBoot should_modify (ModSummary { ms_hspp_opts = dflags }) = @@ -2395,11 +2386,12 @@ enableCodeGenForTH logger home_unit = -- or sums into GHCi while still allowing some code to be interpreted. enableCodeGenForUnboxedTuplesOrSums :: Logger + -> TmpFs -> Backend -> ModNodeMap [Either ErrorMessages ExtendedModSummary] -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary]) -enableCodeGenForUnboxedTuplesOrSums logger = - enableCodeGenWhen logger condition should_modify TFL_GhcSession TFL_CurrentModule +enableCodeGenForUnboxedTuplesOrSums logger tmpfs = + enableCodeGenWhen logger tmpfs condition should_modify TFL_GhcSession TFL_CurrentModule where condition ms = unboxed_tuples_or_sums (ms_hspp_opts ms) && @@ -2418,6 +2410,7 @@ enableCodeGenForUnboxedTuplesOrSums logger = -- marking modules for code generation. enableCodeGenWhen :: Logger + -> TmpFs -> (ModSummary -> Bool) -> (ModSummary -> Bool) -> TempFileLifetime @@ -2425,7 +2418,7 @@ enableCodeGenWhen -> Backend -> ModNodeMap [Either ErrorMessages ExtendedModSummary] -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary]) -enableCodeGenWhen logger condition should_modify staticLife dynLife bcknd nodemap = +enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife bcknd nodemap = traverse (traverse (traverse enable_code_gen)) nodemap where enable_code_gen :: ExtendedModSummary -> IO ExtendedModSummary @@ -2440,9 +2433,9 @@ enableCodeGenWhen logger condition should_modify staticLife dynLife bcknd nodema , ms_mod `Set.member` needs_codegen_set = do let new_temp_file suf dynsuf = do - tn <- newTempName logger dflags staticLife suf + tn <- newTempName logger tmpfs dflags staticLife suf let dyn_tn = tn -<.> dynsuf - addFilesToClean dflags dynLife [dyn_tn] + addFilesToClean tmpfs dynLife [dyn_tn] return tn -- We don't want to create .o or .hi files unless we have been asked -- to by the user. But we need them, so we patch their locations in diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs index 57377212cb..f71b2e17b9 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -31,7 +31,7 @@ import GHC.Types.SourceError import GHC.Types.SrcLoc import Data.List (partition) import GHC.Data.FastString -import GHC.SysTools.FileCleanup +import GHC.Utils.TmpFs import GHC.Iface.Load (cannotFindModule) @@ -82,7 +82,8 @@ doMkDependHS srcs = do when (null (depSuffixes dflags)) $ liftIO $ throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix") - files <- liftIO $ beginMkDependHS logger dflags + tmpfs <- hsc_tmpfs <$> getSession + files <- liftIO $ beginMkDependHS logger tmpfs dflags -- Do the downsweep to find all the modules targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs @@ -131,11 +132,11 @@ data MkDepFiles mkd_tmp_file :: FilePath, -- Name of the temporary file mkd_tmp_hdl :: Handle } -- Handle of the open temporary file -beginMkDependHS :: Logger -> DynFlags -> IO MkDepFiles -beginMkDependHS logger dflags = do +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 dflags TFL_CurrentModule "dep" + tmp_file <- newTempName logger tmpfs 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 f2e740ac41..bf9fbe8405 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -62,7 +62,7 @@ import GHC.Parser.Header import GHC.Parser.Errors.Ppr import GHC.SysTools -import GHC.SysTools.FileCleanup +import GHC.Utils.TmpFs import GHC.Linker.ExtraObj import GHC.Linker.Dynamic @@ -196,6 +196,7 @@ compileOne' m_tc_result mHscMessage = do let logger = hsc_logger hsc_env0 + let tmpfs = hsc_tmpfs hsc_env0 debugTraceMsg logger dflags1 2 (text "compile: input file" <+> text input_fnpp) -- Run the pipeline up to codeGen (so everything up to, but not including, STG) @@ -208,10 +209,10 @@ compileOne' m_tc_result mHscMessage let flags = hsc_dflags hsc_env0 in do unless (gopt Opt_KeepHiFiles flags) $ - addFilesToClean flags TFL_CurrentModule $ + addFilesToClean tmpfs TFL_CurrentModule $ [ml_hi_file $ ms_location summary] unless (gopt Opt_KeepOFiles flags) $ - addFilesToClean flags TFL_GhcSession $ + addFilesToClean tmpfs TFL_GhcSession $ [ml_obj_file $ ms_location summary] case (status, bcknd) of @@ -236,7 +237,7 @@ compileOne' m_tc_result mHscMessage let !linkable = LM (ms_hs_date summary) this_mod [] return $! HomeModInfo iface hmi_details (Just linkable) (HscUpdateSig iface hmi_details, _) -> do - output_fn <- getOutputFilename logger next_phase + output_fn <- getOutputFilename logger tmpfs next_phase (Temporary TFL_CurrentModule) basename dflags next_phase (Just location) @@ -286,7 +287,7 @@ compileOne' m_tc_result mHscMessage (hs_unlinked ++ stub_o) return $! HomeModInfo final_iface hmi_details (Just linkable) (HscRecomp{}, _) -> do - output_fn <- getOutputFilename logger next_phase + output_fn <- getOutputFilename logger tmpfs next_phase (Temporary TFL_CurrentModule) basename dflags next_phase (Just location) -- We're in --make mode: finish the compilation pipeline. @@ -418,7 +419,8 @@ compileEmptyStub dflags hsc_env basename location mod_name = do -- https://gitlab.haskell.org/ghc/ghc/issues/12673 -- and https://github.com/haskell/cabal/issues/2257 let logger = hsc_logger hsc_env - empty_stub <- newTempName logger dflags TFL_CurrentModule "c" + let tmpfs = hsc_tmpfs hsc_env + empty_stub <- newTempName logger tmpfs 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)) @@ -484,6 +486,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do -- libraries. link :: GhcLink -- ^ interactive or batch -> Logger -- ^ Logger + -> TmpFs -> Hooks -> DynFlags -- ^ dynamic flags -> UnitEnv -- ^ unit environment @@ -498,13 +501,13 @@ link :: GhcLink -- ^ interactive or batch -- exports main, i.e., we have good reason to believe that linking -- will succeed. -link ghcLink logger hooks dflags unit_env batch_attempt_linking hpt = +link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking hpt = case linkHook hooks of Nothing -> case ghcLink of NoLink -> return Succeeded - LinkBinary -> link' logger dflags unit_env batch_attempt_linking hpt - LinkStaticLib -> link' logger dflags unit_env batch_attempt_linking hpt - LinkDynLib -> link' logger dflags unit_env batch_attempt_linking hpt + LinkBinary -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt + LinkStaticLib -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt + LinkDynLib -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt LinkInMemory | platformMisc_ghcWithInterpreter $ platformMisc dflags -> -- Not Linking...(demand linker will do the job) @@ -519,13 +522,14 @@ panicBadLink other = panic ("link: GHC not built to link this way: " ++ show other) link' :: Logger + -> TmpFs -> DynFlags -- ^ dynamic flags -> UnitEnv -- ^ unit environment -> Bool -- ^ attempt linking in batch mode? -> HomePackageTable -- ^ what to link -> IO SuccessFlag -link' logger dflags unit_env batch_attempt_linking hpt +link' logger tmpfs dflags unit_env batch_attempt_linking hpt | batch_attempt_linking = do let @@ -565,11 +569,11 @@ link' logger dflags unit_env batch_attempt_linking hpt -- Don't showPass in Batch mode; doLink will do that for us. let link = case ghcLink dflags of - LinkBinary -> linkBinary - LinkStaticLib -> linkStaticLib - LinkDynLib -> linkDynLibCheck + LinkBinary -> linkBinary logger tmpfs + LinkStaticLib -> linkStaticLib logger + LinkDynLib -> linkDynLibCheck logger tmpfs other -> panicBadLink other - link logger dflags unit_env obj_files pkg_deps + link dflags unit_env obj_files pkg_deps debugTraceMsg logger dflags 3 (text "link: done") @@ -678,11 +682,12 @@ doLink hsc_env stop_phase o_files dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env unit_env = hsc_unit_env hsc_env + tmpfs = hsc_tmpfs hsc_env in case ghcLink dflags of NoLink -> return () - LinkBinary -> linkBinary logger dflags unit_env o_files [] - LinkStaticLib -> linkStaticLib logger dflags unit_env o_files [] - LinkDynLib -> linkDynLibCheck logger dflags unit_env o_files [] + LinkBinary -> linkBinary logger tmpfs dflags unit_env o_files [] + LinkStaticLib -> linkStaticLib logger dflags unit_env o_files [] + LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env o_files [] other -> panicBadLink other @@ -719,6 +724,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) dflags = dflags0 { dumpPrefix = Just (basename ++ ".") } hsc_env = hsc_env0 {hsc_dflags = dflags} logger = hsc_logger hsc_env + tmpfs = hsc_tmpfs hsc_env (input_basename, suffix) = splitExtension input_fn suffix' = drop 1 suffix -- strip off the . @@ -766,7 +772,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) input_fn' <- case (start_phase, mb_input_buf) of (RealPhase real_start_phase, Just input_buf) -> do let suffix = phaseInputExt real_start_phase - fn <- newTempName logger dflags TFL_CurrentModule suffix + fn <- newTempName logger tmpfs dflags TFL_CurrentModule suffix hdl <- openBinaryFile fn WriteMode -- Add a LINE pragma so reported source locations will -- mention the real input file, not this temp file. @@ -869,7 +875,8 @@ pipeLoop phase input_fn = do return input_fn output -> do pst <- getPipeState - final_fn <- liftIO $ getOutputFilename logger + tmpfs <- hsc_tmpfs <$> getPipeSession + final_fn <- liftIO $ getOutputFilename logger tmpfs stopPhase output (src_basename env) dflags stopPhase (maybe_loc pst) when (final_fn /= input_fn) $ do @@ -954,10 +961,11 @@ runHookedPhase pp input = do phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath phaseOutputFilename next_phase = do PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv - PipeState{maybe_loc} <- getPipeState + PipeState{maybe_loc,hsc_env} <- getPipeState dflags <- getDynFlags logger <- getLogger - liftIO $ getOutputFilename logger stop_phase output_spec + let tmpfs = hsc_tmpfs hsc_env + liftIO $ getOutputFilename logger tmpfs stop_phase output_spec src_basename dflags next_phase maybe_loc -- | Computes the next output filename for something in the compilation @@ -976,17 +984,24 @@ phaseOutputFilename next_phase = do -- compiling; this can be used to override the default output -- of an object file. (TODO: do we actually need this?) getOutputFilename - :: Logger -> Phase -> PipelineOutput -> String - -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath -getOutputFilename logger stop_phase output basename dflags next_phase maybe_location + :: Logger + -> TmpFs + -> Phase + -> PipelineOutput + -> String + -> DynFlags + -> Phase -- next phase + -> Maybe ModLocation + -> IO FilePath +getOutputFilename logger tmpfs stop_phase output basename dflags next_phase maybe_location | is_last_phase, Persistent <- output = persistent_fn | is_last_phase, SpecificFile <- output = case outputFile dflags of Just f -> return f Nothing -> panic "SpecificFile: No filename" | keep_this_output = persistent_fn - | Temporary lifetime <- output = newTempName logger dflags lifetime suffix - | otherwise = newTempName logger dflags TFL_CurrentModule + | Temporary lifetime <- output = newTempName logger tmpfs dflags lifetime suffix + | otherwise = newTempName logger tmpfs dflags TFL_CurrentModule suffix where hcsuf = hcSuf dflags @@ -1160,7 +1175,10 @@ runPhase (RealPhase (Cpp sf)) input_fn else do output_fn <- phaseOutputFilename (HsPp sf) hsc_env <- getPipeSession - liftIO $ doCpp logger (hsc_dflags hsc_env) (hsc_unit_env hsc_env) + liftIO $ doCpp logger + (hsc_tmpfs hsc_env) + (hsc_dflags hsc_env) + (hsc_unit_env hsc_env) True{-raw-} input_fn output_fn -- re-read the pragmas now that we've preprocessed the file @@ -1389,7 +1407,10 @@ runPhase (RealPhase CmmCpp) input_fn = do hsc_env <- getPipeSession logger <- getLogger output_fn <- phaseOutputFilename Cmm - liftIO $ doCpp logger (hsc_dflags hsc_env) (hsc_unit_env hsc_env) + liftIO $ doCpp logger + (hsc_tmpfs hsc_env) + (hsc_dflags hsc_env) + (hsc_unit_env hsc_env) False{-not raw-} input_fn output_fn return (RealPhase Cmm, output_fn) @@ -1415,6 +1436,7 @@ runPhase (RealPhase cc_phase) input_fn let dflags = hsc_dflags hsc_env let unit_env = hsc_unit_env hsc_env let home_unit = hsc_home_unit hsc_env + let tmpfs = hsc_tmpfs hsc_env let platform = ue_platform unit_env let hcc = cc_phase `eqPhase` HCc @@ -1492,7 +1514,7 @@ runPhase (RealPhase cc_phase) input_fn ghcVersionH <- liftIO $ getGhcVersionPathName dflags unit_env logger <- getLogger - liftIO $ GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger dflags ( + liftIO $ GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags ( [ GHC.SysTools.FileOption "" input_fn , GHC.SysTools.Option "-o" , GHC.SysTools.FileOption "" output_fn @@ -1747,7 +1769,7 @@ runPhase (RealPhase LlvmMangle) input_fn = do -- merge in stub objects runPhase (RealPhase MergeForeign) input_fn = do - PipeState{foreign_os} <- getPipeState + PipeState{foreign_os,hsc_env} <- getPipeState output_fn <- phaseOutputFilename StopLn liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) if null foreign_os @@ -1755,7 +1777,8 @@ runPhase (RealPhase MergeForeign) input_fn = do else do dflags <- getDynFlags logger <- getLogger - liftIO $ joinObjectFiles logger dflags (input_fn : foreign_os) output_fn + let tmpfs = hsc_tmpfs hsc_env + liftIO $ joinObjectFiles logger tmpfs dflags (input_fn : foreign_os) output_fn return (RealPhase StopLn, output_fn) -- warning suppression @@ -1830,14 +1853,14 @@ getHCFilePackages filename = return [] -linkDynLibCheck :: Logger -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () -linkDynLibCheck logger dflags unit_env o_files dep_units = do +linkDynLibCheck :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () +linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do when (haveRtsOptsFlags dflags) $ putLogMsg logger dflags NoReason SevInfo noSrcSpan $ withPprStyle defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ text " Call hs_init_ghc() from your main() function to set these options.") - linkDynLib logger dflags unit_env o_files dep_units + linkDynLib logger tmpfs dflags unit_env o_files dep_units -- ----------------------------------------------------------------------------- @@ -1846,8 +1869,8 @@ linkDynLibCheck logger dflags unit_env o_files dep_units = do -- | Run CPP -- -- UnitState is needed to compute MIN_VERSION macros -doCpp :: Logger -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO () -doCpp logger dflags unit_env raw input_fn output_fn = do +doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO () +doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do let hscpp_opts = picPOpts dflags let cmdline_include_paths = includePaths dflags let unit_state = ue_units unit_env @@ -1862,7 +1885,8 @@ doCpp logger dflags unit_env raw input_fn output_fn = do let verbFlags = getVerbFlags dflags let cpp_prog args | raw = GHC.SysTools.runCpp logger dflags args - | otherwise = GHC.SysTools.runCc Nothing logger dflags (GHC.SysTools.Option "-E" : args) + | otherwise = GHC.SysTools.runCc Nothing logger tmpfs dflags + (GHC.SysTools.Option "-E" : args) let platform = targetPlatform dflags targetArch = stringEncodeArch $ platformArch platform @@ -1905,7 +1929,7 @@ doCpp logger 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 dflags TFL_CurrentModule "h" + then do macro_stub <- newTempName logger tmpfs 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 @@ -2035,12 +2059,12 @@ via gcc. -} -joinObjectFiles :: Logger -> DynFlags -> [FilePath] -> FilePath -> IO () -joinObjectFiles logger dflags o_files output_fn = do +joinObjectFiles :: Logger -> TmpFs -> DynFlags -> [FilePath] -> FilePath -> IO () +joinObjectFiles logger tmpfs dflags o_files output_fn = do let toolSettings' = toolSettings dflags ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings' osInfo = platformOS (targetPlatform dflags) - ld_r args = GHC.SysTools.runMergeObjects logger dflags ( + ld_r args = GHC.SysTools.runMergeObjects logger tmpfs dflags ( -- See Note [Produce big objects on Windows] concat [ [GHC.SysTools.Option "--oformat", GHC.SysTools.Option "pe-bigobj-x86-64"] @@ -2060,14 +2084,14 @@ joinObjectFiles logger dflags o_files output_fn = do if ldIsGnuLd then do - script <- newTempName logger dflags TFL_CurrentModule "ldscript" + script <- newTempName logger tmpfs 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 dflags TFL_CurrentModule "filelist" + filelist <- newTempName logger tmpfs 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/Pipeline/Monad.hs b/compiler/GHC/Driver/Pipeline/Monad.hs index 53d4e98b0d..4a33543527 100644 --- a/compiler/GHC/Driver/Pipeline/Monad.hs +++ b/compiler/GHC/Driver/Pipeline/Monad.hs @@ -22,7 +22,7 @@ import GHC.Driver.Phases import GHC.Driver.Env import GHC.Driver.Plugins -import GHC.SysTools.FileCleanup (TempFileLifetime) +import GHC.Utils.TmpFs (TempFileLifetime) import GHC.Types.SourceFile diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 3633edf48c..8b7ddd321d 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -209,9 +209,6 @@ module GHC.Driver.Session ( LinkerInfo(..), CompilerInfo(..), - -- * File cleanup - FilesToClean(..), emptyFilesToClean, - -- * Include specifications IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes, @@ -271,9 +268,6 @@ import Control.Monad.Trans.Except import Data.Ord import Data.Char import Data.List (intercalate, delete, sortBy) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) import qualified Data.Set as Set import System.FilePath import System.Directory @@ -580,13 +574,6 @@ data DynFlags = DynFlags { packageEnv :: Maybe FilePath, -- ^ Filepath to the package environment file (if overriding default) - -- Temporary files - -- These have to be IORefs, because the defaultCleanupHandler needs to - -- know what to clean when an exception happens - filesToClean :: IORef FilesToClean, - dirsToClean :: IORef (Map FilePath FilePath), - -- The next available suffix to uniquely name a temp file, updated atomically - nextTempSuffix :: IORef Int, -- hsc dynamic flags dumpFlags :: EnumSet DumpFlag, @@ -1061,9 +1048,6 @@ initDynFlags dflags = do platformCanGenerateDynamicToo = platformOS (targetPlatform dflags) /= OSMinGW32 refDynamicTooFailed <- newIORef (not platformCanGenerateDynamicToo) - refNextTempSuffix <- newIORef 0 - refFilesToClean <- newIORef emptyFilesToClean - refDirsToClean <- newIORef Map.empty refRtldInfo <- newIORef Nothing refRtccInfo <- newIORef Nothing wrapperNum <- newIORef emptyModuleEnv @@ -1084,9 +1068,6 @@ initDynFlags dflags = do (useColor dflags, colScheme dflags) return dflags{ dynamicTooFailed = refDynamicTooFailed, - nextTempSuffix = refNextTempSuffix, - filesToClean = refFilesToClean, - dirsToClean = refDirsToClean, nextWrapperNum = wrapperNum, useUnicode = useUnicode', useColor = useColor', @@ -1212,9 +1193,6 @@ defaultDynFlags mySettings llvmConfig = depExcludeMods = [], depSuffixes = [], -- end of ghc -M values - nextTempSuffix = panic "defaultDynFlags: No nextTempSuffix", - filesToClean = panic "defaultDynFlags: No filesToClean", - dirsToClean = panic "defaultDynFlags: No dirsToClean", ghcVersionFile = Nothing, haddockOptions = Nothing, dumpFlags = EnumSet.empty, @@ -4883,26 +4861,6 @@ 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 -- | Initialize the pretty-printing options initSDocContext :: DynFlags -> PprStyle -> SDocContext diff --git a/compiler/GHC/Linker/Dynamic.hs b/compiler/GHC/Linker/Dynamic.hs index 7f4d6cae21..c9d0f0db73 100644 --- a/compiler/GHC/Linker/Dynamic.hs +++ b/compiler/GHC/Linker/Dynamic.hs @@ -23,12 +23,13 @@ import GHC.Linker.MacOS import GHC.Linker.Unit import GHC.SysTools.Tasks import GHC.Utils.Logger +import GHC.Utils.TmpFs import qualified Data.Set as Set import System.FilePath -linkDynLib :: Logger -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () -linkDynLib logger dflags0 unit_env o_files dep_packages +linkDynLib :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () +linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages = do let platform = ue_platform unit_env os = platformOS platform @@ -104,7 +105,7 @@ linkDynLib logger dflags0 unit_env o_files dep_packages Just s -> s Nothing -> "HSdll.dll" - runLink logger dflags ( + runLink logger tmpfs dflags ( map Option verbFlags ++ [ Option "-o" , FileOption "" output_fn @@ -164,7 +165,7 @@ linkDynLib logger dflags0 unit_env o_files dep_packages instName <- case dylibInstallName dflags of Just n -> return n Nothing -> return $ "@rpath" `combine` (takeFileName output_fn) - runLink logger dflags ( + runLink logger tmpfs dflags ( map Option verbFlags ++ [ Option "-dynamiclib" , Option "-o" @@ -206,7 +207,7 @@ linkDynLib logger dflags0 unit_env o_files dep_packages -- See Note [-Bsymbolic assumptions by GHC] ["-Wl,-Bsymbolic" | not unregisterised] - runLink logger dflags ( + runLink logger tmpfs dflags ( map Option verbFlags ++ libmLinkOpts ++ [ Option "-o" diff --git a/compiler/GHC/Linker/ExtraObj.hs b/compiler/GHC/Linker/ExtraObj.hs index b8dca3e8dc..15fe7b69fd 100644 --- a/compiler/GHC/Linker/ExtraObj.hs +++ b/compiler/GHC/Linker/ExtraObj.hs @@ -32,6 +32,7 @@ import GHC.Utils.Error import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Logger +import GHC.Utils.TmpFs import GHC.Driver.Session import GHC.Driver.Ppr @@ -39,7 +40,6 @@ import GHC.Driver.Ppr import qualified GHC.Data.ShortText as ST import GHC.SysTools.Elf -import GHC.SysTools.FileCleanup import GHC.SysTools.Tasks import GHC.SysTools.Info import GHC.Linker.Unit @@ -48,13 +48,13 @@ import Control.Monad.IO.Class import Control.Monad import Data.Maybe -mkExtraObj :: Logger -> DynFlags -> UnitState -> Suffix -> String -> IO FilePath -mkExtraObj logger dflags unit_state extn xs - = do cFile <- newTempName logger dflags TFL_CurrentModule extn - oFile <- newTempName logger dflags TFL_GhcSession "o" +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" writeFile cFile xs ccInfo <- liftIO $ getCompilerInfo logger dflags - runCc Nothing logger dflags + runCc Nothing logger tmpfs dflags ([Option "-c", FileOption "" cFile, Option "-o", @@ -87,8 +87,8 @@ mkExtraObj logger dflags unit_state extn xs -- -- On Windows, when making a shared library we also may need a DllMain. -- -mkExtraObjToLinkIntoBinary :: Logger -> DynFlags -> UnitState -> IO (Maybe FilePath) -mkExtraObjToLinkIntoBinary logger dflags unit_state = do +mkExtraObjToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitState -> IO (Maybe FilePath) +mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state = do when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ logInfo logger dflags $ withPprStyle defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ @@ -114,7 +114,7 @@ mkExtraObjToLinkIntoBinary logger dflags unit_state = do _ -> mk_extra_obj exeMain where - mk_extra_obj = fmap Just . mkExtraObj logger dflags unit_state "c" . showSDoc dflags + mk_extra_obj = fmap Just . mkExtraObj logger tmpfs dflags unit_state "c" . showSDoc dflags exeMain = vcat [ text "#include <Rts.h>", @@ -163,12 +163,12 @@ mkExtraObjToLinkIntoBinary logger dflags unit_state = do -- this was included as inline assembly in the main.c file but this -- is pretty fragile. gas gets upset trying to calculate relative offsets -- that span the .note section (notably .text) when debug info is present -mkNoteObjsToLinkIntoBinary :: Logger -> DynFlags -> UnitEnv -> [UnitId] -> IO [FilePath] -mkNoteObjsToLinkIntoBinary logger dflags unit_env dep_packages = do +mkNoteObjsToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [UnitId] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary logger tmpfs dflags unit_env dep_packages = do link_info <- getLinkInfo dflags unit_env dep_packages if (platformSupportsSavingLinkOpts (platformOS platform )) - then fmap (:[]) $ mkExtraObj logger dflags unit_state "s" (showSDoc dflags (link_opts link_info)) + then fmap (:[]) $ mkExtraObj logger tmpfs dflags unit_state "s" (showSDoc dflags (link_opts link_info)) else return [] where diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs index 4533bc014f..cc1fde53a3 100644 --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -58,7 +58,6 @@ import GHC.ByteCode.Asm import GHC.ByteCode.Types import GHC.SysTools -import GHC.SysTools.FileCleanup import GHC.Types.Basic import GHC.Types.Name @@ -71,6 +70,7 @@ import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Error import GHC.Utils.Logger +import GHC.Utils.TmpFs import GHC.Unit.Env import GHC.Unit.Finder @@ -919,11 +919,12 @@ dynLoadObjs hsc_env pls@LoaderState{..} objs = do let unit_env = hsc_unit_env hsc_env let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env + let tmpfs = hsc_tmpfs hsc_env let platform = ue_platform unit_env let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ] let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ] (soFile, libPath , libName) <- - newTempLibName logger dflags TFL_CurrentModule (platformSOExt platform) + newTempLibName logger tmpfs dflags TFL_CurrentModule (platformSOExt platform) let dflags2 = dflags { -- We don't want the original ldInputs in @@ -969,10 +970,10 @@ dynLoadObjs hsc_env pls@LoaderState{..} objs = do -- link all "loaded packages" so symbols in those can be resolved -- Note: We are loading packages with local scope, so to see the -- symbols in this link we must link all loaded packages again. - linkDynLib logger dflags2 unit_env objs pkgs_loaded + linkDynLib logger tmpfs dflags2 unit_env objs pkgs_loaded -- if we got this far, extend the lifetime of the library file - changeTempFilesLifetime dflags TFL_GhcSession [soFile] + changeTempFilesLifetime tmpfs TFL_GhcSession [soFile] m <- loadDLL hsc_env soFile case m of Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos } diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs index 32640ddf62..4e2367f9e6 100644 --- a/compiler/GHC/Linker/Static.hs +++ b/compiler/GHC/Linker/Static.hs @@ -13,7 +13,6 @@ import GHC.Settings import GHC.SysTools import GHC.SysTools.Ar -import GHC.SysTools.FileCleanup import GHC.Unit.Env import GHC.Unit.Types @@ -23,6 +22,7 @@ import GHC.Unit.State import GHC.Utils.Logger import GHC.Utils.Monad import GHC.Utils.Misc +import GHC.Utils.TmpFs import GHC.Linker.MacOS import GHC.Linker.Unit @@ -64,11 +64,11 @@ it is supported by both gcc and clang. Anecdotally nvcc supports -Xlinker, but not -Wl. -} -linkBinary :: Logger -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () +linkBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () linkBinary = linkBinary' False -linkBinary' :: Bool -> Logger -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () -linkBinary' staticLink logger dflags unit_env o_files dep_units = do +linkBinary' :: Bool -> Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () +linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do let platform = ue_platform unit_env unit_state = ue_units unit_env toolSettings' = toolSettings dflags @@ -123,7 +123,7 @@ linkBinary' staticLink logger 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 dflags + tmpDir <- newTempDir logger tmpfs dflags sequence_ [ copyFile lib (tmpDir </> basename) | (lib, basename) <- libs] return [ "-L" ++ tmpDir ] @@ -138,8 +138,8 @@ linkBinary' staticLink logger dflags unit_env o_files dep_units = do let lib_paths = libraryPaths dflags let lib_path_opts = map ("-L"++) lib_paths - extraLinkObj <- maybeToList <$> mkExtraObjToLinkIntoBinary logger dflags unit_state - noteLinkObjs <- mkNoteObjsToLinkIntoBinary logger dflags unit_env dep_units + extraLinkObj <- maybeToList <$> mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state + noteLinkObjs <- mkNoteObjsToLinkIntoBinary logger tmpfs dflags unit_env dep_units let (pre_hs_libs, post_hs_libs) @@ -181,16 +181,16 @@ linkBinary' staticLink logger dflags unit_env o_files dep_units = do let extra_ld_inputs = ldInputs dflags rc_objs <- case platformOS platform of - OSMinGW32 | gopt Opt_GenManifest dflags -> maybeCreateManifest logger dflags output_fn + OSMinGW32 | gopt Opt_GenManifest dflags -> maybeCreateManifest logger tmpfs dflags output_fn _ -> return [] let link dflags args | staticLink = GHC.SysTools.runLibtool logger dflags args | platformOS platform == OSDarwin = do - GHC.SysTools.runLink logger dflags args + GHC.SysTools.runLink logger tmpfs dflags args GHC.Linker.MacOS.runInjectRPaths logger dflags pkg_lib_paths output_fn | otherwise - = GHC.SysTools.runLink logger dflags args + = GHC.SysTools.runLink logger tmpfs dflags args link dflags ( map GHC.SysTools.Option verbFlags diff --git a/compiler/GHC/Linker/Windows.hs b/compiler/GHC/Linker/Windows.hs index 8e1f60d2c6..8be0802002 100644 --- a/compiler/GHC/Linker/Windows.hs +++ b/compiler/GHC/Linker/Windows.hs @@ -6,7 +6,7 @@ where import GHC.Prelude import GHC.SysTools import GHC.Driver.Session -import GHC.SysTools.FileCleanup +import GHC.Utils.TmpFs import GHC.Utils.Logger import System.FilePath @@ -14,10 +14,11 @@ import System.Directory maybeCreateManifest :: Logger + -> TmpFs -> DynFlags -> FilePath -- ^ filename of executable -> IO [FilePath] -- ^ extra objects to embed, maybe -maybeCreateManifest logger dflags exe_filename = do +maybeCreateManifest logger tmpfs dflags exe_filename = do let manifest_filename = exe_filename <.> "manifest" manifest = "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n\ @@ -44,9 +45,9 @@ maybeCreateManifest logger dflags exe_filename = do if not (gopt Opt_EmbedManifest dflags) then return [] else do - rc_filename <- newTempName logger dflags TFL_CurrentModule "rc" + rc_filename <- newTempName logger tmpfs dflags TFL_CurrentModule "rc" rc_obj_filename <- - newTempName logger dflags TFL_GhcSession (objectSuf dflags) + newTempName logger tmpfs 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 d4ed196c91..e66929056c 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- @@ -61,7 +62,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Logger -import GHC.SysTools.FileCleanup +import GHC.Utils.TmpFs import GHC.Data.Stream import GHC.Data.OrdList @@ -79,6 +80,7 @@ data CodeGenState = CodeGenState { codegen_used_info :: !(OrdList CmmInfoTable) codeGen :: Logger + -> TmpFs -> DynFlags -> Module -> InfoTableProvMap @@ -89,7 +91,7 @@ codeGen :: Logger -> Stream IO CmmGroup (CStub, ModuleLFInfos) -- Output as a stream, so codegen can -- be interleaved with output -codeGen logger dflags this_mod ip_map@(InfoTableProvMap (UniqMap denv) _) data_tycons +codeGen logger tmpfs dflags this_mod ip_map@(InfoTableProvMap (UniqMap denv) _) data_tycons cost_centre_info stg_binds hpc_info = do { -- cg: run the code generator, and yield the resulting CmmGroup -- Using an IORef to store the state is a bit crude, but otherwise @@ -124,7 +126,7 @@ codeGen logger dflags this_mod ip_map@(InfoTableProvMap (UniqMap denv) _) data_t -- Note [pipeline-split-init]. ; cg (mkModuleInit cost_centre_info this_mod hpc_info) - ; mapM_ (cg . cgTopBinding logger dflags) stg_binds + ; mapM_ (cg . cgTopBinding logger tmpfs dflags) stg_binds -- Put datatype_stuff after code_stuff, because the -- datatype closure table (for enumeration types) to -- (say) PrelBase_True_closure, which is defined in @@ -179,39 +181,38 @@ This is so that we can write the top level processing in a compositional style, with the increasing static environment being plumbed as a state variable. -} -cgTopBinding :: Logger -> DynFlags -> CgStgTopBinding -> FCode () -cgTopBinding _logger dflags (StgTopLifted (StgNonRec id rhs)) - = do { let (info, fcode) = cgTopRhs dflags NonRecursive id rhs - ; fcode - ; addBindC info - } - -cgTopBinding _logger dflags (StgTopLifted (StgRec pairs)) - = do { let (bndrs, rhss) = unzip pairs - ; let pairs' = zip bndrs rhss - r = unzipWith (cgTopRhs dflags Recursive) pairs' - (infos, fcodes) = unzip r - ; addBindsC infos - ; sequence_ fcodes - } - -cgTopBinding logger dflags (StgTopStringLit id str) = do - let label = mkBytesLabel (idName id) - -- emit either a CmmString literal or dump the string in a file and emit a - -- CmmFileEmbed literal. - -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr - let isNCG = backend dflags == NCG - isSmall = fromIntegral (BS.length str) <= binBlobThreshold dflags - asString = binBlobThreshold dflags == 0 || isSmall - - (lit,decl) = if not isNCG || asString - then mkByteStringCLit label str - else mkFileEmbedLit label $ unsafePerformIO $ do - bFile <- newTempName logger dflags TFL_CurrentModule ".dat" - BS.writeFile bFile str - return bFile - emitDecl decl - addBindC (litIdInfo (targetPlatform dflags) id mkLFStringLit lit) +cgTopBinding :: Logger -> TmpFs -> DynFlags -> CgStgTopBinding -> FCode () +cgTopBinding logger tmpfs dflags = \case + StgTopLifted (StgNonRec id rhs) -> do + let (info, fcode) = cgTopRhs dflags NonRecursive id rhs + fcode + addBindC info + + StgTopLifted (StgRec pairs) -> do + let (bndrs, rhss) = unzip pairs + let pairs' = zip bndrs rhss + r = unzipWith (cgTopRhs dflags Recursive) pairs' + (infos, fcodes) = unzip r + addBindsC infos + sequence_ fcodes + + StgTopStringLit id str -> do + let label = mkBytesLabel (idName id) + -- emit either a CmmString literal or dump the string in a file and emit a + -- CmmFileEmbed literal. + -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr + let isNCG = backend dflags == NCG + isSmall = fromIntegral (BS.length str) <= binBlobThreshold dflags + asString = binBlobThreshold dflags == 0 || isSmall + + (lit,decl) = if not isNCG || asString + then mkByteStringCLit label str + else mkFileEmbedLit label $ unsafePerformIO $ do + bFile <- newTempName logger tmpfs dflags TFL_CurrentModule ".dat" + BS.writeFile bFile str + return bFile + emitDecl decl + addBindC (litIdInfo (targetPlatform dflags) id mkLFStringLit lit) cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ()) diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs index df12cb4af7..1159506d18 100644 --- a/compiler/GHC/SysTools/Process.hs +++ b/compiler/GHC/SysTools/Process.hs @@ -10,16 +10,19 @@ module GHC.SysTools.Process where #include "HsVersions.h" +import GHC.Prelude + +import GHC.Driver.Session + import GHC.Utils.Exception import GHC.Utils.Error -import GHC.Driver.Session -import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Prelude import GHC.Utils.Misc import GHC.Utils.Logger + import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan ) +import GHC.Data.FastString import Control.Concurrent import Data.Char @@ -31,7 +34,7 @@ import System.IO import System.IO.Error as IO import System.Process -import GHC.SysTools.FileCleanup +import GHC.Utils.TmpFs -- | Enable process jobs support on Windows if it can be expected to work (e.g. -- @process >= 1.6.9.0@). @@ -155,10 +158,16 @@ runSomething logger dflags phase_name pgm args = -- https://gcc.gnu.org/wiki/Response_Files -- https://gitlab.haskell.org/ghc/ghc/issues/10777 runSomethingResponseFile - :: Logger -> DynFlags -> (String->String) -> String -> String -> [Option] - -> Maybe [(String,String)] -> IO () - -runSomethingResponseFile logger dflags filter_fn phase_name pgm args mb_env = + :: Logger + -> TmpFs + -> DynFlags + -> (String->String) + -> String + -> String + -> [Option] + -> Maybe [(String,String)] + -> IO () +runSomethingResponseFile logger tmpfs dflags filter_fn phase_name pgm args mb_env = runSomethingWith logger dflags phase_name pgm args $ \real_args -> do fp <- getResponseFile real_args let args = ['@':fp] @@ -166,7 +175,7 @@ runSomethingResponseFile logger dflags filter_fn phase_name pgm args mb_env = return (r,()) where getResponseFile args = do - fp <- newTempName logger dflags TFL_CurrentModule "rsp" + fp <- newTempName logger tmpfs dflags TFL_CurrentModule "rsp" withFile fp WriteMode $ \h -> do #if defined(mingw32_HOST_OS) hSetEncoding h latin1 diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs index b802623325..694d3155c1 100644 --- a/compiler/GHC/SysTools/Tasks.hs +++ b/compiler/GHC/SysTools/Tasks.hs @@ -25,6 +25,7 @@ import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Logger +import GHC.Utils.TmpFs import Data.List (tails, isPrefixOf) import System.IO @@ -62,15 +63,15 @@ runPp logger dflags args = traceToolCommand logger dflags "pp" $ do runSomething logger dflags "Haskell pre-processor" prog (args ++ opts) -- | Run compiler of C-like languages and raw objects (such as gcc or clang). -runCc :: Maybe ForeignSrcLang -> Logger -> DynFlags -> [Option] -> IO () -runCc mLanguage logger dflags args = traceToolCommand logger dflags "cc" $ do +runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> DynFlags -> [Option] -> IO () +runCc mLanguage logger tmpfs dflags args = traceToolCommand logger dflags "cc" $ do let p = pgm_c dflags args1 = map Option userOpts args2 = languageOptions ++ args ++ args1 -- We take care to pass -optc flags in args1 last to ensure that the -- user can override flags passed by GHC. See #14452. mb_env <- getGccEnv args2 - runSomethingResponseFile logger dflags cc_filter "C Compiler" p args2 mb_env + runSomethingResponseFile logger tmpfs dflags cc_filter "C Compiler" p args2 mb_env where -- discard some harmless warnings from gcc that we can't turn off cc_filter = unlines . doFilter . lines @@ -239,8 +240,8 @@ figureLlvmVersion logger dflags = traceToolCommand logger dflags "llc" $ do -runLink :: Logger -> DynFlags -> [Option] -> IO () -runLink logger dflags args = traceToolCommand logger dflags "linker" $ do +runLink :: Logger -> TmpFs -> DynFlags -> [Option] -> IO () +runLink logger tmpfs dflags args = traceToolCommand logger dflags "linker" $ do -- See Note [Run-time linker info] -- -- `-optl` args come at the end, so that later `-l` options @@ -251,7 +252,7 @@ runLink logger dflags args = traceToolCommand logger dflags "linker" $ do optl_args = map Option (getOpts dflags opt_l) args2 = args0 ++ linkargs ++ args ++ optl_args mb_env <- getGccEnv args2 - runSomethingResponseFile logger dflags ld_filter "Linker" p args2 mb_env + runSomethingResponseFile logger tmpfs dflags ld_filter "Linker" p args2 mb_env where ld_filter = case (platformOS (targetPlatform dflags)) of OSSolaris2 -> sunos_ld_filter @@ -303,18 +304,23 @@ ld: warning: symbol referencing errors ld_warning_found = not . null . snd . ld_warn_break -- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline. -runMergeObjects :: Logger -> DynFlags -> [Option] -> IO () -runMergeObjects logger dflags args = traceToolCommand logger dflags "merge-objects" $ do - let (p,args0) = pgm_lm dflags - optl_args = map Option (getOpts dflags opt_lm) - args2 = args0 ++ args ++ optl_args - -- N.B. Darwin's ld64 doesn't support response files. Consequently we only - -- use them on Windows where they are truly necessary. +runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO () #if defined(mingw32_HOST_OS) - mb_env <- getGccEnv args2 - runSomethingResponseFile logger dflags id "Merge objects" p args2 mb_env +runMergeObjects logger tmpfs dflags args = +#else +runMergeObjects logger _tmpfs dflags args = +#endif + traceToolCommand logger dflags "merge-objects" $ do + let (p,args0) = pgm_lm dflags + optl_args = map Option (getOpts dflags opt_lm) + args2 = args0 ++ args ++ optl_args + -- N.B. Darwin's ld64 doesn't support response files. Consequently we only + -- use them on Windows where they are truly necessary. +#if defined(mingw32_HOST_OS) + mb_env <- getGccEnv args2 + runSomethingResponseFile logger tmpfs dflags id "Merge objects" p args2 mb_env #else - runSomething logger dflags "Merge objects" p args2 + runSomething logger dflags "Merge objects" p args2 #endif runLibtool :: Logger -> DynFlags -> [Option] -> IO () diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index ab45f3f373..7ae4ccb0f6 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -122,7 +122,7 @@ import GHC.Utils.Lexeme import GHC.Utils.Outputable import GHC.Utils.Logger -import GHC.SysTools.FileCleanup ( newTempName, TempFileLifetime(..) ) +import GHC.Utils.TmpFs ( newTempName, TempFileLifetime(..) ) import GHC.Data.FastString import GHC.Data.Maybe( MaybeErr(..) ) @@ -1140,7 +1140,8 @@ instance TH.Quasi TcM where qAddTempFile suffix = do dflags <- getDynFlags logger <- getLogger - liftIO $ newTempName logger dflags TFL_GhcSession suffix + tmpfs <- hsc_tmpfs <$> getTopEnv + liftIO $ newTempName logger tmpfs dflags TFL_GhcSession suffix qAddTopDecls thds = do l <- getSrcSpanM diff --git a/compiler/GHC/SysTools/FileCleanup.hs b/compiler/GHC/Utils/TmpFs.hs index 1b73ad2812..d108f55b3b 100644 --- a/compiler/GHC/SysTools/FileCleanup.hs +++ b/compiler/GHC/Utils/TmpFs.hs @@ -1,11 +1,26 @@ {-# LANGUAGE CPP #-} -module GHC.SysTools.FileCleanup - ( TempFileLifetime(..) - , cleanTempDirs, cleanTempFiles, cleanCurrentModuleTempFiles - , addFilesToClean, changeTempFilesLifetime - , newTempName, newTempLibName, newTempDir - , withSystemTempDirectory, withTempDirectory - ) where + +-- | Temporary file-system management +module GHC.Utils.TmpFs + ( TmpFs + , initTmpFs + , forkTmpFsFrom + , mergeTmpFsInto + , FilesToClean(..) + , emptyFilesToClean + , TempFileLifetime(..) + , cleanTempDirs + , cleanTempFiles + , cleanCurrentModuleTempFiles + , addFilesToClean + , changeTempFilesLifetime + , newTempName + , newTempLibName + , newTempDir + , withSystemTempDirectory + , withTempDirectory + ) +where import GHC.Prelude @@ -20,7 +35,9 @@ import GHC.Driver.Phases import Control.Monad import Data.List (partition) import qualified Data.Set as Set +import Data.Set (Set) import qualified Data.Map as Map +import Data.Map (Map) import Data.IORef import System.Directory import System.FilePath @@ -30,6 +47,40 @@ import System.IO.Error import qualified System.Posix.Internals #endif +-- | Temporary file-system +data TmpFs = TmpFs + { tmp_dirs_to_clean :: IORef (Map FilePath FilePath) + -- ^ Maps system temporary directory (passed via settings or DynFlags) to + -- an actual temporary directory for this process. + -- + -- It's a Map probably to support changing the system temporary directory + -- over time. + -- + -- Shared with forked TmpFs. + + , tmp_next_suffix :: IORef Int + -- ^ The next available suffix to uniquely name a temp file, updated + -- atomically. + -- + -- Shared with forked TmpFs. + + , tmp_files_to_clean :: IORef FilesToClean + -- ^ Files to clean (per session or per module) + -- + -- Not shared with forked TmpFs. + } + +-- | A collection of files that must be deleted before ghc exits. +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 + -- 'cleanCurrentModuleTempFiles' is called, or otherwise at the end of + -- the session. + } + -- | Used when a temp file is created. This determines which component Set of -- FilesToClean will get the temp file data TempFileLifetime @@ -41,20 +92,63 @@ data TempFileLifetime -- runGhc(T) deriving (Show) -cleanTempDirs :: Logger -> DynFlags -> IO () -cleanTempDirs logger dflags + +-- | An empty FilesToClean +emptyFilesToClean :: FilesToClean +emptyFilesToClean = FilesToClean Set.empty Set.empty + +-- | Merge two FilesToClean +mergeFilesToClean :: FilesToClean -> FilesToClean -> FilesToClean +mergeFilesToClean x y = FilesToClean + { ftcGhcSession = Set.union (ftcGhcSession x) (ftcGhcSession y) + , ftcCurrentModule = Set.union (ftcCurrentModule x) (ftcCurrentModule y) + } + +-- | Initialise an empty TmpFs +initTmpFs :: IO TmpFs +initTmpFs = do + files <- newIORef emptyFilesToClean + dirs <- newIORef Map.empty + next <- newIORef 0 + return $ TmpFs + { tmp_files_to_clean = files + , tmp_dirs_to_clean = dirs + , tmp_next_suffix = next + } + +-- | Initialise an empty TmpFs sharing unique numbers and per-process temporary +-- directories with the given TmpFs +forkTmpFsFrom :: TmpFs -> IO TmpFs +forkTmpFsFrom old = do + files <- newIORef emptyFilesToClean + return $ TmpFs + { tmp_files_to_clean = files + , tmp_dirs_to_clean = tmp_dirs_to_clean old + , tmp_next_suffix = tmp_next_suffix old + } + +-- | Merge the first TmpFs into the second. +-- +-- The first TmpFs is returned emptied. +mergeTmpFsInto :: TmpFs -> TmpFs -> IO () +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_ - $ do let ref = dirsToClean dflags + $ do let ref = tmp_dirs_to_clean tmpfs ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds) removeTmpDirs logger dflags (Map.elems ds) --- | Delete all files in @filesToClean dflags@. -cleanTempFiles :: Logger -> DynFlags -> IO () -cleanTempFiles logger dflags +-- | Delete all files in @tmp_files_to_clean@. +cleanTempFiles :: Logger -> TmpFs -> DynFlags -> IO () +cleanTempFiles logger tmpfs dflags = unless (gopt Opt_KeepTmpFiles dflags) $ mask_ - $ do let ref = filesToClean dflags + $ do let ref = tmp_files_to_clean tmpfs to_delete <- atomicModifyIORef' ref $ \FilesToClean { ftcCurrentModule = cm_files @@ -63,15 +157,15 @@ cleanTempFiles logger dflags , Set.toList cm_files ++ Set.toList gs_files) removeTmpFiles logger dflags to_delete --- | Delete all files in @filesToClean dflags@. That have lifetime +-- | Delete all files in @tmp_files_to_clean@. That have lifetime -- TFL_CurrentModule. -- If a file must be cleaned eventually, but must survive a -- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession. -cleanCurrentModuleTempFiles :: Logger -> DynFlags -> IO () -cleanCurrentModuleTempFiles logger dflags +cleanCurrentModuleTempFiles :: Logger -> TmpFs -> DynFlags -> IO () +cleanCurrentModuleTempFiles logger tmpfs dflags = unless (gopt Opt_KeepTmpFiles dflags) $ mask_ - $ do let ref = filesToClean dflags + $ do let ref = tmp_files_to_clean tmpfs to_delete <- atomicModifyIORef' ref $ \ftc@FilesToClean{ftcCurrentModule = cm_files} -> (ftc {ftcCurrentModule = Set.empty}, Set.toList cm_files) @@ -81,8 +175,8 @@ cleanCurrentModuleTempFiles logger dflags -- '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) $ +addFilesToClean :: TmpFs -> TempFileLifetime -> [FilePath] -> IO () +addFilesToClean tmpfs lifetime new_files = modifyIORef' (tmp_files_to_clean tmpfs) $ \FilesToClean { ftcCurrentModule = cm_files , ftcGhcSession = gs_files @@ -100,76 +194,76 @@ addFilesToClean dflags lifetime new_files = modifyIORef' (filesToClean dflags) $ -- | 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 +changeTempFilesLifetime :: TmpFs -> TempFileLifetime -> [FilePath] -> IO () +changeTempFilesLifetime tmpfs lifetime files = do FilesToClean { ftcCurrentModule = cm_files , ftcGhcSession = gs_files - } <- readIORef (filesToClean dflags) + } <- readIORef (tmp_files_to_clean tmpfs) 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 + addFilesToClean tmpfs lifetime existing_files -- Return a unique numeric temp file suffix -newTempSuffix :: DynFlags -> IO Int -newTempSuffix dflags = - atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n) +newTempSuffix :: TmpFs -> IO Int +newTempSuffix tmpfs = + atomicModifyIORef' (tmp_next_suffix tmpfs) $ \n -> (n+1,n) -- Find a temporary name that doesn't already exist. -newTempName :: Logger -> DynFlags -> TempFileLifetime -> Suffix -> IO FilePath -newTempName logger dflags lifetime extn - = do d <- getTempDir logger dflags +newTempName :: Logger -> TmpFs -> DynFlags -> TempFileLifetime -> Suffix -> IO FilePath +newTempName logger tmpfs dflags lifetime extn + = do d <- getTempDir logger tmpfs dflags findTempName (d </> "ghc_") -- See Note [Deterministic base name] where findTempName :: FilePath -> IO FilePath findTempName prefix - = do n <- newTempSuffix dflags + = do n <- newTempSuffix tmpfs let filename = prefix ++ show n <.> extn b <- doesFileExist filename if b then findTempName prefix else do -- clean it up later - addFilesToClean dflags lifetime [filename] + addFilesToClean tmpfs lifetime [filename] return filename -newTempDir :: Logger -> DynFlags -> IO FilePath -newTempDir logger dflags - = do d <- getTempDir logger dflags +newTempDir :: Logger -> TmpFs -> DynFlags -> IO FilePath +newTempDir logger tmpfs dflags + = do d <- getTempDir logger tmpfs dflags findTempDir (d </> "ghc_") where findTempDir :: FilePath -> IO FilePath findTempDir prefix - = do n <- newTempSuffix dflags + = do n <- newTempSuffix tmpfs let filename = prefix ++ show n b <- doesDirectoryExist filename if b then findTempDir prefix else do createDirectory filename - -- see mkTempDir below; this is wrong: -> consIORef (dirsToClean dflags) filename + -- see mkTempDir below; this is wrong: -> consIORef (tmp_dirs_to_clean tmpfs) filename return filename -newTempLibName :: Logger -> DynFlags -> TempFileLifetime -> Suffix +newTempLibName :: Logger -> TmpFs -> DynFlags -> TempFileLifetime -> Suffix -> IO (FilePath, FilePath, String) -newTempLibName logger dflags lifetime extn - = do d <- getTempDir logger dflags +newTempLibName logger tmpfs dflags lifetime extn + = do d <- getTempDir logger tmpfs dflags findTempName d ("ghc_") where findTempName :: FilePath -> String -> IO (FilePath, FilePath, String) findTempName dir prefix - = do n <- newTempSuffix dflags -- See Note [Deterministic base name] + = do n <- newTempSuffix tmpfs -- 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] + addFilesToClean tmpfs lifetime [filename] return (filename, dir, libname) -- Return our temporary directory within tmp_dir, creating one if we -- don't have one yet. -getTempDir :: Logger -> DynFlags -> IO FilePath -getTempDir logger dflags = do +getTempDir :: Logger -> TmpFs -> DynFlags -> IO FilePath +getTempDir logger tmpfs dflags = do mapping <- readIORef dir_ref case Map.lookup tmp_dir mapping of Nothing -> do @@ -179,17 +273,17 @@ getTempDir logger dflags = do Just dir -> return dir where tmp_dir = tmpDir dflags - dir_ref = dirsToClean dflags + dir_ref = tmp_dirs_to_clean tmpfs mkTempDir :: FilePath -> IO FilePath mkTempDir prefix = do - n <- newTempSuffix dflags + n <- newTempSuffix tmpfs 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 + -- 2. Update the tmp_dirs_to_clean 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 diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index cb1ba59db9..148d578130 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -560,7 +560,6 @@ Library GHC.SysTools.Ar GHC.SysTools.BaseDir GHC.SysTools.Elf - GHC.SysTools.FileCleanup GHC.SysTools.Info GHC.SysTools.Process GHC.SysTools.Tasks @@ -717,6 +716,7 @@ Library GHC.Utils.Panic.Plain GHC.Utils.Ppr GHC.Utils.Ppr.Colour + GHC.Utils.TmpFs Language.Haskell.Syntax Language.Haskell.Syntax.Binds diff --git a/testsuite/tests/parser/should_run/CountAstDeps.stdout b/testsuite/tests/parser/should_run/CountAstDeps.stdout index 7553cdc3e3..0546006424 100644 --- a/testsuite/tests/parser/should_run/CountAstDeps.stdout +++ b/testsuite/tests/parser/should_run/CountAstDeps.stdout @@ -134,7 +134,6 @@ GHC.Settings.Constants GHC.Stg.Syntax GHC.StgToCmm.Types GHC.SysTools.BaseDir -GHC.SysTools.FileCleanup GHC.SysTools.Terminal GHC.Tc.Errors.Hole.FitTypes GHC.Tc.Types @@ -233,6 +232,7 @@ GHC.Utils.Panic GHC.Utils.Panic.Plain GHC.Utils.Ppr GHC.Utils.Ppr.Colour +GHC.Utils.TmpFs Language.Haskell.Syntax Language.Haskell.Syntax.Binds Language.Haskell.Syntax.Decls diff --git a/testsuite/tests/parser/should_run/CountParserDeps.stdout b/testsuite/tests/parser/should_run/CountParserDeps.stdout index c79c839f0a..786d2ab721 100644 --- a/testsuite/tests/parser/should_run/CountParserDeps.stdout +++ b/testsuite/tests/parser/should_run/CountParserDeps.stdout @@ -142,7 +142,6 @@ GHC.Settings.Constants GHC.Stg.Syntax GHC.StgToCmm.Types GHC.SysTools.BaseDir -GHC.SysTools.FileCleanup GHC.SysTools.Terminal GHC.Tc.Errors.Hole.FitTypes GHC.Tc.Types @@ -241,6 +240,7 @@ GHC.Utils.Panic GHC.Utils.Panic.Plain GHC.Utils.Ppr GHC.Utils.Ppr.Colour +GHC.Utils.TmpFs Language.Haskell.Syntax Language.Haskell.Syntax.Binds Language.Haskell.Syntax.Decls |