[Git][ghc/ghc][wip/romes/12935] Revert "wip: temp file names"
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Tue Sep 3 09:54:49 UTC 2024
Matthew Pickering pushed to branch wip/romes/12935 at Glasgow Haskell Compiler / GHC
Commits:
5f85ad9f by Matthew Pickering at 2024-09-03T10:53:43+01:00
Revert "wip: temp file names"
This reverts commit 43be188ecf5de7b65fe093f7e9bd04228788ef33.
- - - - -
2 changed files:
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Utils/TmpFs.hs
Changes:
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -2924,22 +2924,19 @@ runParPipelines worker_limit plugin_hsc_env diag_wrapper mHscMessager all_pipeli
atomically $ writeTVar stopped_var True
wait_log_thread
-withLocalTmpFS :: TmpFs -> (TmpFs -> IO a) -> IO a
-withLocalTmpFS tmpfs act = do
+withLocalTmpFS :: RunMakeM a -> RunMakeM a
+withLocalTmpFS act = do
let initialiser = do
- liftIO $ forkTmpFsFrom tmpfs
- finaliser tmpfs_local = do
- liftIO $ mergeTmpFsInto tmpfs_local tmpfs
+ MakeEnv{..} <- ask
+ lcl_tmpfs <- liftIO $ forkTmpFsFrom (hsc_tmpfs hsc_env)
+ return $ hsc_env { hsc_tmpfs = lcl_tmpfs }
+ finaliser lcl_env = do
+ gbl_env <- ask
+ liftIO $ mergeTmpFsInto (hsc_tmpfs lcl_env) (hsc_tmpfs (hsc_env gbl_env))
-- Add remaining files which weren't cleaned up into local tmp fs for
-- clean-up later.
-- Clear the logQueue if this node had it's own log queue
- MC.bracket initialiser finaliser act
-
-withLocalTmpFSMake :: MakeEnv -> (MakeEnv -> IO a) -> IO a
-withLocalTmpFSMake env k =
- withLocalTmpFS (hsc_tmpfs (hsc_env env)) $ \lcl_tmpfs
- -> k (env { hsc_env = (hsc_env env) { hsc_tmpfs = lcl_tmpfs }})
-
+ MC.bracket initialiser finaliser $ \lcl_hsc_env -> local (\env -> env { hsc_env = lcl_hsc_env}) act
-- | Run the given actions and then wait for them all to finish.
runAllPipelines :: WorkerLimit -> MakeEnv -> [MakeAction] -> IO ()
@@ -2961,18 +2958,16 @@ runAllPipelines worker_limit env acts = do
runLoop :: (((forall a. IO a -> IO a) -> IO ()) -> IO a) -> MakeEnv -> [MakeAction] -> IO [a]
runLoop _ _env [] = return []
runLoop fork_thread env (MakeAction act res_var :acts) = do
-
- -- withLocalTmpFs has to occur outside of fork to remain deterministic
- new_thread <- withLocalTmpFSMake env $ \lcl_env ->
+ new_thread <-
fork_thread $ \unmask -> (do
- mres <- (unmask $ run_pipeline lcl_env act)
+ mres <- (unmask $ run_pipeline (withLocalTmpFS act))
`MC.onException` (putMVar res_var Nothing) -- Defensive: If there's an unhandled exception then still signal the failure.
putMVar res_var mres)
threads <- runLoop fork_thread env acts
return (new_thread : threads)
where
- run_pipeline :: MakeEnv -> RunMakeM a -> IO (Maybe a)
- run_pipeline env p = runMaybeT (runReaderT p env)
+ run_pipeline :: RunMakeM a -> IO (Maybe a)
+ run_pipeline p = runMaybeT (runReaderT p env)
data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a))
=====================================
compiler/GHC/Utils/TmpFs.hs
=====================================
@@ -10,7 +10,6 @@ module GHC.Utils.TmpFs
, emptyPathsToClean
, TempFileLifetime(..)
, TempDir (..)
- , getTempDir
, cleanTempDirs
, cleanTempFiles
, cleanCurrentModuleTempFiles
@@ -65,8 +64,6 @@ data TmpFs = TmpFs
--
-- Shared with forked TmpFs.
- , tmp_dir_prefix :: String
-
, tmp_files_to_clean :: IORef PathsToClean
-- ^ Files to clean (per session or per module)
--
@@ -124,7 +121,6 @@ initTmpFs = do
, tmp_subdirs_to_clean = subdirs
, tmp_dirs_to_clean = dirs
, tmp_next_suffix = next
- , tmp_dir_prefix = "tmp"
}
-- | Initialise an empty TmpFs sharing unique numbers and per-process temporary
@@ -136,16 +132,11 @@ forkTmpFsFrom :: TmpFs -> IO TmpFs
forkTmpFsFrom old = do
files <- newIORef emptyPathsToClean
subdirs <- newIORef emptyPathsToClean
- counter <- newIORef 0
- prefix <- newTempSuffix old
-
-
return $ TmpFs
{ tmp_files_to_clean = files
, tmp_subdirs_to_clean = subdirs
, tmp_dirs_to_clean = tmp_dirs_to_clean old
- , tmp_next_suffix = counter
- , tmp_dir_prefix = prefix
+ , tmp_next_suffix = tmp_next_suffix old
}
-- | Merge the first TmpFs into the second.
@@ -268,11 +259,9 @@ changeTempFilesLifetime tmpfs lifetime files = do
addFilesToClean tmpfs lifetime existing_files
-- Return a unique numeric temp file suffix
-newTempSuffix :: TmpFs -> IO String
-newTempSuffix tmpfs = do
- n <- atomicModifyIORef' (tmp_next_suffix tmpfs) $ \n -> (n+1,n)
- return $ tmp_dir_prefix tmpfs ++ "_" ++ show 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 -> TmpFs -> TempDir -> TempFileLifetime -> Suffix -> IO FilePath
@@ -282,8 +271,8 @@ newTempName logger tmpfs tmp_dir lifetime extn
where
findTempName :: FilePath -> IO FilePath
findTempName prefix
- = do suffix <- newTempSuffix tmpfs
- let filename = prefix ++ suffix <.> extn
+ = do n <- newTempSuffix tmpfs
+ let filename = prefix ++ show n <.> extn
b <- doesFileExist filename
if b then findTempName prefix
else do -- clean it up later
@@ -306,8 +295,8 @@ newTempSubDir logger tmpfs tmp_dir
where
findTempDir :: FilePath -> IO FilePath
findTempDir prefix
- = do suffix <- newTempSuffix tmpfs
- let name = prefix ++ suffix
+ = do n <- newTempSuffix tmpfs
+ let name = prefix ++ show n
b <- doesDirectoryExist name
if b then findTempDir prefix
else (do
@@ -325,8 +314,8 @@ newTempLibName logger tmpfs tmp_dir lifetime extn
where
findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)
findTempName dir prefix
- = do suffix <- newTempSuffix tmpfs -- See Note [Deterministic base name]
- let libname = prefix ++ suffix
+ = 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
@@ -351,8 +340,8 @@ getTempDir logger tmpfs (TempDir tmp_dir) = do
mkTempDir :: FilePath -> IO FilePath
mkTempDir prefix = do
- suffix <- newTempSuffix tmpfs
- let our_dir = prefix ++ suffix
+ n <- newTempSuffix tmpfs
+ let our_dir = prefix ++ show n
-- 1. Speculatively create our new directory.
createDirectory our_dir
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5f85ad9fafd3fa885ab888c6b4ea160794cdf0b9
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5f85ad9fafd3fa885ab888c6b4ea160794cdf0b9
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240903/80c146ab/attachment-0001.html>
More information about the ghc-commits
mailing list