diff options
Diffstat (limited to 'compiler/GHC/Utils/TmpFs.hs')
| -rw-r--r-- | compiler/GHC/Utils/TmpFs.hs | 409 |
1 files changed, 409 insertions, 0 deletions
diff --git a/compiler/GHC/Utils/TmpFs.hs b/compiler/GHC/Utils/TmpFs.hs new file mode 100644 index 0000000000..d108f55b3b --- /dev/null +++ b/compiler/GHC/Utils/TmpFs.hs @@ -0,0 +1,409 @@ +{-# LANGUAGE CPP #-} + +-- | 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 + +import GHC.Driver.Session +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Logger +import GHC.Utils.Misc +import GHC.Utils.Exception as Exception +import GHC.Driver.Phases + +import Control.Monad +import Data.List (partition) +import qualified Data.Set as Set +import Data.Set (Set) +import qualified Data.Map as Map +import Data.Map (Map) +import Data.IORef +import System.Directory +import System.FilePath +import System.IO.Error + +#if !defined(mingw32_HOST_OS) +import qualified System.Posix.Internals +#endif + +-- | 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 + = TFL_CurrentModule + -- ^ A file with lifetime TFL_CurrentModule will be cleaned up at the + -- end of upweep_mod + | TFL_GhcSession + -- ^ A file with lifetime TFL_GhcSession will be cleaned up at the end of + -- runGhc(T) + deriving (Show) + + +-- | 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 = tmp_dirs_to_clean tmpfs + ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds) + removeTmpDirs logger dflags (Map.elems ds) + +-- | Delete all files in @tmp_files_to_clean@. +cleanTempFiles :: Logger -> TmpFs -> DynFlags -> IO () +cleanTempFiles logger tmpfs dflags + = unless (gopt Opt_KeepTmpFiles dflags) + $ mask_ + $ do let ref = tmp_files_to_clean tmpfs + to_delete <- atomicModifyIORef' ref $ + \FilesToClean + { ftcCurrentModule = cm_files + , ftcGhcSession = gs_files + } -> ( emptyFilesToClean + , Set.toList cm_files ++ Set.toList gs_files) + removeTmpFiles logger dflags to_delete + +-- | 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 -> TmpFs -> DynFlags -> IO () +cleanCurrentModuleTempFiles logger tmpfs dflags + = unless (gopt Opt_KeepTmpFiles dflags) + $ mask_ + $ 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) + removeTmpFiles logger dflags to_delete + +-- | Ensure that new_files are cleaned on the next call of +-- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime. +-- If any of new_files are already tracked, they will have their lifetime +-- updated. +addFilesToClean :: TmpFs -> TempFileLifetime -> [FilePath] -> IO () +addFilesToClean tmpfs lifetime new_files = modifyIORef' (tmp_files_to_clean tmpfs) $ + \FilesToClean + { ftcCurrentModule = cm_files + , ftcGhcSession = gs_files + } -> case lifetime of + TFL_CurrentModule -> FilesToClean + { ftcCurrentModule = cm_files `Set.union` new_files_set + , ftcGhcSession = gs_files `Set.difference` new_files_set + } + TFL_GhcSession -> FilesToClean + { ftcCurrentModule = cm_files `Set.difference` new_files_set + , ftcGhcSession = gs_files `Set.union` new_files_set + } + where + new_files_set = Set.fromList new_files + +-- | Update the lifetime of files already being tracked. If any files are +-- not being tracked they will be discarded. +changeTempFilesLifetime :: TmpFs -> TempFileLifetime -> [FilePath] -> IO () +changeTempFilesLifetime tmpfs lifetime files = do + FilesToClean + { ftcCurrentModule = cm_files + , ftcGhcSession = gs_files + } <- 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 tmpfs lifetime existing_files + +-- Return a unique numeric temp file suffix +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 -> 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 tmpfs + let filename = prefix ++ show n <.> extn + b <- doesFileExist filename + if b then findTempName prefix + else do -- clean it up later + addFilesToClean tmpfs lifetime [filename] + return filename + +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 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 (tmp_dirs_to_clean tmpfs) filename + return filename + +newTempLibName :: Logger -> TmpFs -> DynFlags -> TempFileLifetime -> Suffix + -> IO (FilePath, FilePath, String) +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 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 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 -> TmpFs -> DynFlags -> IO FilePath +getTempDir logger tmpfs dflags = do + mapping <- readIORef dir_ref + case Map.lookup tmp_dir mapping of + Nothing -> do + pid <- getProcessID + let prefix = tmp_dir </> "ghc" ++ show pid ++ "_" + mask_ $ mkTempDir prefix + Just dir -> return dir + where + tmp_dir = tmpDir dflags + dir_ref = tmp_dirs_to_clean tmpfs + + mkTempDir :: FilePath -> IO FilePath + mkTempDir prefix = do + n <- newTempSuffix tmpfs + let our_dir = prefix ++ show n + + -- 1. Speculatively create our new directory. + createDirectory our_dir + + -- 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 + Just dir -> (mapping, Just dir) + Nothing -> (Map.insert tmp_dir our_dir mapping, Nothing) + + -- 3. If there was an existing entry, return it and delete the + -- directory we created. Otherwise return the directory we created. + case their_dir of + Nothing -> do + debugTraceMsg logger dflags 2 $ + text "Created temporary directory:" <+> text our_dir + return our_dir + Just dir -> do + removeDirectory our_dir + return dir + `catchIO` \e -> if isAlreadyExistsError e + then mkTempDir prefix else ioError e + +{- Note [Deterministic base name] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The filename of temporary files, especially the basename of C files, can end +up in the output in some form, e.g. as part of linker debug information. In the +interest of bit-wise exactly reproducible compilation (#4012), the basename of +the temporary file no longer contains random information (it used to contain +the process id). + +This is ok, as the temporary directory used contains the pid (see getTempDir). +-} +removeTmpDirs :: Logger -> DynFlags -> [FilePath] -> IO () +removeTmpDirs logger dflags ds + = traceCmd logger dflags "Deleting temp dirs" + ("Deleting: " ++ unwords ds) + (mapM_ (removeWith logger dflags removeDirectory) ds) + +removeTmpFiles :: Logger -> DynFlags -> [FilePath] -> IO () +removeTmpFiles logger dflags fs + = warnNon $ + traceCmd logger dflags "Deleting temp files" + ("Deleting: " ++ unwords deletees) + (mapM_ (removeWith logger dflags removeFile) deletees) + where + -- Flat out refuse to delete files that are likely to be source input + -- files (is there a worse bug than having a compiler delete your source + -- files?) + -- + -- Deleting source files is a sign of a bug elsewhere, so prominently flag + -- the condition. + warnNon act + | null non_deletees = act + | otherwise = do + putMsg logger dflags (text "WARNING - NOT deleting source files:" + <+> hsep (map text non_deletees)) + act + + (non_deletees, deletees) = partition isHaskellUserSrcFilename fs + +removeWith :: Logger -> DynFlags -> (FilePath -> IO ()) -> FilePath -> IO () +removeWith logger dflags remover f = remover f `catchIO` + (\e -> + let msg = if isDoesNotExistError e + then text "Warning: deleting non-existent" <+> text f + else text "Warning: exception raised when deleting" + <+> text f <> colon + $$ text (show e) + in debugTraceMsg logger dflags 2 msg + ) + +#if defined(mingw32_HOST_OS) +-- relies on Int == Int32 on Windows +foreign import ccall unsafe "_getpid" getProcessID :: IO Int +#else +getProcessID :: IO Int +getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral +#endif + +-- The following three functions are from the `temporary` package. + +-- | Create and use a temporary directory in the system standard temporary +-- directory. +-- +-- Behaves exactly the same as 'withTempDirectory', except that the parent +-- temporary directory will be that returned by 'getTemporaryDirectory'. +withSystemTempDirectory :: String -- ^ Directory name template. See 'openTempFile'. + -> (FilePath -> IO a) -- ^ Callback that can use the directory + -> IO a +withSystemTempDirectory template action = + getTemporaryDirectory >>= \tmpDir -> withTempDirectory tmpDir template action + + +-- | Create and use a temporary directory. +-- +-- Creates a new temporary directory inside the given directory, making use +-- of the template. The temp directory is deleted after use. For example: +-- +-- > withTempDirectory "src" "sdist." $ \tmpDir -> do ... +-- +-- The @tmpDir@ will be a new subdirectory of the given directory, e.g. +-- @src/sdist.342@. +withTempDirectory :: FilePath -- ^ Temp directory to create the directory in + -> String -- ^ Directory name template. See 'openTempFile'. + -> (FilePath -> IO a) -- ^ Callback that can use the directory + -> IO a +withTempDirectory targetDir template = + Exception.bracket + (createTempDirectory targetDir template) + (ignoringIOErrors . removeDirectoryRecursive) + +ignoringIOErrors :: IO () -> IO () +ignoringIOErrors ioe = ioe `catchIO` const (return ()) + + +createTempDirectory :: FilePath -> String -> IO FilePath +createTempDirectory dir template = do + pid <- getProcessID + findTempName pid + where findTempName x = do + let path = dir </> template ++ show x + createDirectory path + return path + `catchIO` \e -> if isAlreadyExistsError e + then findTempName (x+1) else ioError e |