summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/Driver/CodeOutput.hs56
-rw-r--r--compiler/GHC/Driver/Env/Types.hs4
-rw-r--r--compiler/GHC/Driver/Main.hs17
-rw-r--r--compiler/GHC/Driver/Make.hs107
-rw-r--r--compiler/GHC/Driver/MakeFile.hs11
-rw-r--r--compiler/GHC/Driver/Pipeline.hs112
-rw-r--r--compiler/GHC/Driver/Pipeline/Monad.hs2
-rw-r--r--compiler/GHC/Driver/Session.hs42
-rw-r--r--compiler/GHC/Linker/Dynamic.hs11
-rw-r--r--compiler/GHC/Linker/ExtraObj.hs24
-rw-r--r--compiler/GHC/Linker/Loader.hs9
-rw-r--r--compiler/GHC/Linker/Static.hs20
-rw-r--r--compiler/GHC/Linker/Windows.hs9
-rw-r--r--compiler/GHC/StgToCmm.hs73
-rw-r--r--compiler/GHC/SysTools/Process.hs27
-rw-r--r--compiler/GHC/SysTools/Tasks.hs38
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs5
-rw-r--r--compiler/GHC/Utils/TmpFs.hs (renamed from compiler/GHC/SysTools/FileCleanup.hs)188
18 files changed, 432 insertions, 323 deletions
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
View Lorry Controller Status