never executed always true always false
1 {-# LANGUAGE CPP #-}
2
3 -- | Temporary file-system management
4 module GHC.Utils.TmpFs
5 ( TmpFs
6 , initTmpFs
7 , forkTmpFsFrom
8 , mergeTmpFsInto
9 , FilesToClean(..)
10 , emptyFilesToClean
11 , TempFileLifetime(..)
12 , TempDir (..)
13 , cleanTempDirs
14 , cleanTempFiles
15 , cleanCurrentModuleTempFiles
16 , addFilesToClean
17 , changeTempFilesLifetime
18 , newTempName
19 , newTempLibName
20 , newTempDir
21 , withSystemTempDirectory
22 , withTempDirectory
23 )
24 where
25
26 import GHC.Prelude
27
28 import GHC.Utils.Error
29 import GHC.Utils.Outputable
30 import GHC.Utils.Logger
31 import GHC.Utils.Misc
32 import GHC.Utils.Exception as Exception
33 import GHC.Driver.Phases
34
35 import Data.List (partition)
36 import qualified Data.Set as Set
37 import Data.Set (Set)
38 import qualified Data.Map as Map
39 import Data.Map (Map)
40 import Data.IORef
41 import System.Directory
42 import System.FilePath
43 import System.IO.Error
44
45 #if !defined(mingw32_HOST_OS)
46 import qualified System.Posix.Internals
47 #endif
48
49 -- | Temporary file-system
50 data TmpFs = TmpFs
51 { tmp_dirs_to_clean :: IORef (Map FilePath FilePath)
52 -- ^ Maps system temporary directory (passed via settings or DynFlags) to
53 -- an actual temporary directory for this process.
54 --
55 -- It's a Map probably to support changing the system temporary directory
56 -- over time.
57 --
58 -- Shared with forked TmpFs.
59
60 , tmp_next_suffix :: IORef Int
61 -- ^ The next available suffix to uniquely name a temp file, updated
62 -- atomically.
63 --
64 -- Shared with forked TmpFs.
65
66 , tmp_files_to_clean :: IORef FilesToClean
67 -- ^ Files to clean (per session or per module)
68 --
69 -- Not shared with forked TmpFs.
70 }
71
72 -- | A collection of files that must be deleted before ghc exits.
73 data FilesToClean = FilesToClean
74 { ftcGhcSession :: !(Set FilePath)
75 -- ^ Files that will be deleted at the end of runGhc(T)
76
77 , ftcCurrentModule :: !(Set FilePath)
78 -- ^ Files that will be deleted the next time
79 -- 'cleanCurrentModuleTempFiles' is called, or otherwise at the end of
80 -- the session.
81 }
82
83 -- | Used when a temp file is created. This determines which component Set of
84 -- FilesToClean will get the temp file
85 data TempFileLifetime
86 = TFL_CurrentModule
87 -- ^ A file with lifetime TFL_CurrentModule will be cleaned up at the
88 -- end of upweep_mod
89 | TFL_GhcSession
90 -- ^ A file with lifetime TFL_GhcSession will be cleaned up at the end of
91 -- runGhc(T)
92 deriving (Show)
93
94 newtype TempDir = TempDir FilePath
95
96 -- | An empty FilesToClean
97 emptyFilesToClean :: FilesToClean
98 emptyFilesToClean = FilesToClean Set.empty Set.empty
99
100 -- | Merge two FilesToClean
101 mergeFilesToClean :: FilesToClean -> FilesToClean -> FilesToClean
102 mergeFilesToClean x y = FilesToClean
103 { ftcGhcSession = Set.union (ftcGhcSession x) (ftcGhcSession y)
104 , ftcCurrentModule = Set.union (ftcCurrentModule x) (ftcCurrentModule y)
105 }
106
107 -- | Initialise an empty TmpFs
108 initTmpFs :: IO TmpFs
109 initTmpFs = do
110 files <- newIORef emptyFilesToClean
111 dirs <- newIORef Map.empty
112 next <- newIORef 0
113 return $ TmpFs
114 { tmp_files_to_clean = files
115 , tmp_dirs_to_clean = dirs
116 , tmp_next_suffix = next
117 }
118
119 -- | Initialise an empty TmpFs sharing unique numbers and per-process temporary
120 -- directories with the given TmpFs
121 forkTmpFsFrom :: TmpFs -> IO TmpFs
122 forkTmpFsFrom old = do
123 files <- newIORef emptyFilesToClean
124 return $ TmpFs
125 { tmp_files_to_clean = files
126 , tmp_dirs_to_clean = tmp_dirs_to_clean old
127 , tmp_next_suffix = tmp_next_suffix old
128 }
129
130 -- | Merge the first TmpFs into the second.
131 --
132 -- The first TmpFs is returned emptied.
133 mergeTmpFsInto :: TmpFs -> TmpFs -> IO ()
134 mergeTmpFsInto src dst = do
135 src_files <- atomicModifyIORef' (tmp_files_to_clean src) (\s -> (emptyFilesToClean, s))
136 atomicModifyIORef' (tmp_files_to_clean dst) (\s -> (mergeFilesToClean src_files s, ()))
137
138 cleanTempDirs :: Logger -> TmpFs -> IO ()
139 cleanTempDirs logger tmpfs
140 = mask_
141 $ do let ref = tmp_dirs_to_clean tmpfs
142 ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)
143 removeTmpDirs logger (Map.elems ds)
144
145 -- | Delete all files in @tmp_files_to_clean@.
146 cleanTempFiles :: Logger -> TmpFs -> IO ()
147 cleanTempFiles logger tmpfs
148 = mask_
149 $ do let ref = tmp_files_to_clean tmpfs
150 to_delete <- atomicModifyIORef' ref $
151 \FilesToClean
152 { ftcCurrentModule = cm_files
153 , ftcGhcSession = gs_files
154 } -> ( emptyFilesToClean
155 , Set.toList cm_files ++ Set.toList gs_files)
156 removeTmpFiles logger to_delete
157
158 -- | Delete all files in @tmp_files_to_clean@. That have lifetime
159 -- TFL_CurrentModule.
160 -- If a file must be cleaned eventually, but must survive a
161 -- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession.
162 cleanCurrentModuleTempFiles :: Logger -> TmpFs -> IO ()
163 cleanCurrentModuleTempFiles logger tmpfs
164 = mask_
165 $ do let ref = tmp_files_to_clean tmpfs
166 to_delete <- atomicModifyIORef' ref $
167 \ftc@FilesToClean{ftcCurrentModule = cm_files} ->
168 (ftc {ftcCurrentModule = Set.empty}, Set.toList cm_files)
169 removeTmpFiles logger to_delete
170
171 -- | Ensure that new_files are cleaned on the next call of
172 -- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime.
173 -- If any of new_files are already tracked, they will have their lifetime
174 -- updated.
175 addFilesToClean :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
176 addFilesToClean tmpfs lifetime new_files = modifyIORef' (tmp_files_to_clean tmpfs) $
177 \FilesToClean
178 { ftcCurrentModule = cm_files
179 , ftcGhcSession = gs_files
180 } -> case lifetime of
181 TFL_CurrentModule -> FilesToClean
182 { ftcCurrentModule = cm_files `Set.union` new_files_set
183 , ftcGhcSession = gs_files `Set.difference` new_files_set
184 }
185 TFL_GhcSession -> FilesToClean
186 { ftcCurrentModule = cm_files `Set.difference` new_files_set
187 , ftcGhcSession = gs_files `Set.union` new_files_set
188 }
189 where
190 new_files_set = Set.fromList new_files
191
192 -- | Update the lifetime of files already being tracked. If any files are
193 -- not being tracked they will be discarded.
194 changeTempFilesLifetime :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
195 changeTempFilesLifetime tmpfs lifetime files = do
196 FilesToClean
197 { ftcCurrentModule = cm_files
198 , ftcGhcSession = gs_files
199 } <- readIORef (tmp_files_to_clean tmpfs)
200 let old_set = case lifetime of
201 TFL_CurrentModule -> gs_files
202 TFL_GhcSession -> cm_files
203 existing_files = [f | f <- files, f `Set.member` old_set]
204 addFilesToClean tmpfs lifetime existing_files
205
206 -- Return a unique numeric temp file suffix
207 newTempSuffix :: TmpFs -> IO Int
208 newTempSuffix tmpfs =
209 atomicModifyIORef' (tmp_next_suffix tmpfs) $ \n -> (n+1,n)
210
211 -- Find a temporary name that doesn't already exist.
212 newTempName :: Logger -> TmpFs -> TempDir -> TempFileLifetime -> Suffix -> IO FilePath
213 newTempName logger tmpfs tmp_dir lifetime extn
214 = do d <- getTempDir logger tmpfs tmp_dir
215 findTempName (d </> "ghc_") -- See Note [Deterministic base name]
216 where
217 findTempName :: FilePath -> IO FilePath
218 findTempName prefix
219 = do n <- newTempSuffix tmpfs
220 let filename = prefix ++ show n <.> extn
221 b <- doesFileExist filename
222 if b then findTempName prefix
223 else do -- clean it up later
224 addFilesToClean tmpfs lifetime [filename]
225 return filename
226
227 newTempDir :: Logger -> TmpFs -> TempDir -> IO FilePath
228 newTempDir logger tmpfs tmp_dir
229 = do d <- getTempDir logger tmpfs tmp_dir
230 findTempDir (d </> "ghc_")
231 where
232 findTempDir :: FilePath -> IO FilePath
233 findTempDir prefix
234 = do n <- newTempSuffix tmpfs
235 let filename = prefix ++ show n
236 b <- doesDirectoryExist filename
237 if b then findTempDir prefix
238 else do createDirectory filename
239 -- see mkTempDir below; this is wrong: -> consIORef (tmp_dirs_to_clean tmpfs) filename
240 return filename
241
242 newTempLibName :: Logger -> TmpFs -> TempDir -> TempFileLifetime -> Suffix
243 -> IO (FilePath, FilePath, String)
244 newTempLibName logger tmpfs tmp_dir lifetime extn
245 = do d <- getTempDir logger tmpfs tmp_dir
246 findTempName d ("ghc_")
247 where
248 findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)
249 findTempName dir prefix
250 = do n <- newTempSuffix tmpfs -- See Note [Deterministic base name]
251 let libname = prefix ++ show n
252 filename = dir </> "lib" ++ libname <.> extn
253 b <- doesFileExist filename
254 if b then findTempName dir prefix
255 else do -- clean it up later
256 addFilesToClean tmpfs lifetime [filename]
257 return (filename, dir, libname)
258
259
260 -- Return our temporary directory within tmp_dir, creating one if we
261 -- don't have one yet.
262 getTempDir :: Logger -> TmpFs -> TempDir -> IO FilePath
263 getTempDir logger tmpfs (TempDir tmp_dir) = do
264 mapping <- readIORef dir_ref
265 case Map.lookup tmp_dir mapping of
266 Nothing -> do
267 pid <- getProcessID
268 let prefix = tmp_dir </> "ghc" ++ show pid ++ "_"
269 mask_ $ mkTempDir prefix
270 Just dir -> return dir
271 where
272 dir_ref = tmp_dirs_to_clean tmpfs
273
274 mkTempDir :: FilePath -> IO FilePath
275 mkTempDir prefix = do
276 n <- newTempSuffix tmpfs
277 let our_dir = prefix ++ show n
278
279 -- 1. Speculatively create our new directory.
280 createDirectory our_dir
281
282 -- 2. Update the tmp_dirs_to_clean mapping unless an entry already exists
283 -- (i.e. unless another thread beat us to it).
284 their_dir <- atomicModifyIORef' dir_ref $ \mapping ->
285 case Map.lookup tmp_dir mapping of
286 Just dir -> (mapping, Just dir)
287 Nothing -> (Map.insert tmp_dir our_dir mapping, Nothing)
288
289 -- 3. If there was an existing entry, return it and delete the
290 -- directory we created. Otherwise return the directory we created.
291 case their_dir of
292 Nothing -> do
293 debugTraceMsg logger 2 $
294 text "Created temporary directory:" <+> text our_dir
295 return our_dir
296 Just dir -> do
297 removeDirectory our_dir
298 return dir
299 `Exception.catchIO` \e -> if isAlreadyExistsError e
300 then mkTempDir prefix else ioError e
301
302 {- Note [Deterministic base name]
303 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
304
305 The filename of temporary files, especially the basename of C files, can end
306 up in the output in some form, e.g. as part of linker debug information. In the
307 interest of bit-wise exactly reproducible compilation (#4012), the basename of
308 the temporary file no longer contains random information (it used to contain
309 the process id).
310
311 This is ok, as the temporary directory used contains the pid (see getTempDir).
312 -}
313 removeTmpDirs :: Logger -> [FilePath] -> IO ()
314 removeTmpDirs logger ds
315 = traceCmd logger "Deleting temp dirs"
316 ("Deleting: " ++ unwords ds)
317 (mapM_ (removeWith logger removeDirectory) ds)
318
319 removeTmpFiles :: Logger -> [FilePath] -> IO ()
320 removeTmpFiles logger fs
321 = warnNon $
322 traceCmd logger "Deleting temp files"
323 ("Deleting: " ++ unwords deletees)
324 (mapM_ (removeWith logger removeFile) deletees)
325 where
326 -- Flat out refuse to delete files that are likely to be source input
327 -- files (is there a worse bug than having a compiler delete your source
328 -- files?)
329 --
330 -- Deleting source files is a sign of a bug elsewhere, so prominently flag
331 -- the condition.
332 warnNon act
333 | null non_deletees = act
334 | otherwise = do
335 putMsg logger (text "WARNING - NOT deleting source files:"
336 <+> hsep (map text non_deletees))
337 act
338
339 (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
340
341 removeWith :: Logger -> (FilePath -> IO ()) -> FilePath -> IO ()
342 removeWith logger remover f = remover f `Exception.catchIO`
343 (\e ->
344 let msg = if isDoesNotExistError e
345 then text "Warning: deleting non-existent" <+> text f
346 else text "Warning: exception raised when deleting"
347 <+> text f <> colon
348 $$ text (show e)
349 in debugTraceMsg logger 2 msg
350 )
351
352 #if defined(mingw32_HOST_OS)
353 -- relies on Int == Int32 on Windows
354 foreign import ccall unsafe "_getpid" getProcessID :: IO Int
355 #else
356 getProcessID :: IO Int
357 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
358 #endif
359
360 -- The following three functions are from the `temporary` package.
361
362 -- | Create and use a temporary directory in the system standard temporary
363 -- directory.
364 --
365 -- Behaves exactly the same as 'withTempDirectory', except that the parent
366 -- temporary directory will be that returned by 'getTemporaryDirectory'.
367 withSystemTempDirectory :: String -- ^ Directory name template. See 'openTempFile'.
368 -> (FilePath -> IO a) -- ^ Callback that can use the directory
369 -> IO a
370 withSystemTempDirectory template action =
371 getTemporaryDirectory >>= \tmpDir -> withTempDirectory tmpDir template action
372
373
374 -- | Create and use a temporary directory.
375 --
376 -- Creates a new temporary directory inside the given directory, making use
377 -- of the template. The temp directory is deleted after use. For example:
378 --
379 -- > withTempDirectory "src" "sdist." $ \tmpDir -> do ...
380 --
381 -- The @tmpDir@ will be a new subdirectory of the given directory, e.g.
382 -- @src/sdist.342@.
383 withTempDirectory :: FilePath -- ^ Temp directory to create the directory in
384 -> String -- ^ Directory name template. See 'openTempFile'.
385 -> (FilePath -> IO a) -- ^ Callback that can use the directory
386 -> IO a
387 withTempDirectory targetDir template =
388 Exception.bracket
389 (createTempDirectory targetDir template)
390 (ignoringIOErrors . removeDirectoryRecursive)
391
392 ignoringIOErrors :: IO () -> IO ()
393 ignoringIOErrors ioe = ioe `Exception.catchIO` const (return ())
394
395
396 createTempDirectory :: FilePath -> String -> IO FilePath
397 createTempDirectory dir template = do
398 pid <- getProcessID
399 findTempName pid
400 where findTempName x = do
401 let path = dir </> template ++ show x
402 createDirectory path
403 return path
404 `Exception.catchIO` \e -> if isAlreadyExistsError e
405 then findTempName (x+1) else ioError e