compiler: Write .o files atomically. See #14533
[ghc.git] / compiler / main / FileCleanup.hs
1 {-# LANGUAGE CPP #-}
2 module FileCleanup
3 ( TempFileLifetime(..)
4 , cleanTempDirs, cleanTempFiles, cleanCurrentModuleTempFiles
5 , addFilesToClean, changeTempFilesLifetime
6 , newTempName, newTempLibName, newTempDir
7 , withSystemTempDirectory, withTempDirectory
8 ) where
9
10 import GhcPrelude
11
12 import DynFlags
13 import ErrUtils
14 import Outputable
15 import Util
16 import Exception
17 import DriverPhases
18
19 import Control.Monad
20 import Data.List
21 import qualified Data.Set as Set
22 import qualified Data.Map as Map
23 import Data.IORef
24 import System.Directory
25 import System.FilePath
26 import System.IO.Error
27
28 #if !defined(mingw32_HOST_OS)
29 import qualified System.Posix.Internals
30 #endif
31
32 -- | Used when a temp file is created. This determines which component Set of
33 -- FilesToClean will get the temp file
34 data TempFileLifetime
35 = TFL_CurrentModule
36 -- ^ A file with lifetime TFL_CurrentModule will be cleaned up at the
37 -- end of upweep_mod
38 | TFL_GhcSession
39 -- ^ A file with lifetime TFL_GhcSession will be cleaned up at the end of
40 -- runGhc(T)
41 deriving (Show)
42
43 cleanTempDirs :: DynFlags -> IO ()
44 cleanTempDirs dflags
45 = unless (gopt Opt_KeepTmpFiles dflags)
46 $ mask_
47 $ do let ref = dirsToClean dflags
48 ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)
49 removeTmpDirs dflags (Map.elems ds)
50
51 -- | Delete all files in @filesToClean dflags@.
52 cleanTempFiles :: DynFlags -> IO ()
53 cleanTempFiles dflags
54 = unless (gopt Opt_KeepTmpFiles dflags)
55 $ mask_
56 $ do let ref = filesToClean dflags
57 to_delete <- atomicModifyIORef' ref $
58 \FilesToClean
59 { ftcCurrentModule = cm_files
60 , ftcGhcSession = gs_files
61 } -> ( emptyFilesToClean
62 , Set.toList cm_files ++ Set.toList gs_files)
63 removeTmpFiles dflags to_delete
64
65 -- | Delete all files in @filesToClean dflags@. That have lifetime
66 -- TFL_CurrentModule.
67 -- If a file must be cleaned eventually, but must survive a
68 -- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession.
69 cleanCurrentModuleTempFiles :: DynFlags -> IO ()
70 cleanCurrentModuleTempFiles dflags
71 = unless (gopt Opt_KeepTmpFiles dflags)
72 $ mask_
73 $ do let ref = filesToClean dflags
74 to_delete <- atomicModifyIORef' ref $
75 \ftc@FilesToClean{ftcCurrentModule = cm_files} ->
76 (ftc {ftcCurrentModule = Set.empty}, Set.toList cm_files)
77 removeTmpFiles dflags to_delete
78
79 -- | Ensure that new_files are cleaned on the next call of
80 -- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime.
81 -- If any of new_files are already tracked, they will have their lifetime
82 -- updated.
83 addFilesToClean :: DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
84 addFilesToClean dflags lifetime new_files = modifyIORef' (filesToClean dflags) $
85 \FilesToClean
86 { ftcCurrentModule = cm_files
87 , ftcGhcSession = gs_files
88 } -> case lifetime of
89 TFL_CurrentModule -> FilesToClean
90 { ftcCurrentModule = cm_files `Set.union` new_files_set
91 , ftcGhcSession = gs_files `Set.difference` new_files_set
92 }
93 TFL_GhcSession -> FilesToClean
94 { ftcCurrentModule = cm_files `Set.difference` new_files_set
95 , ftcGhcSession = gs_files `Set.union` new_files_set
96 }
97 where
98 new_files_set = Set.fromList new_files
99
100 -- | Update the lifetime of files already being tracked. If any files are
101 -- not being tracked they will be discarded.
102 changeTempFilesLifetime :: DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
103 changeTempFilesLifetime dflags lifetime files = do
104 FilesToClean
105 { ftcCurrentModule = cm_files
106 , ftcGhcSession = gs_files
107 } <- readIORef (filesToClean dflags)
108 let old_set = case lifetime of
109 TFL_CurrentModule -> gs_files
110 TFL_GhcSession -> cm_files
111 existing_files = [f | f <- files, f `Set.member` old_set]
112 addFilesToClean dflags lifetime existing_files
113
114 -- Return a unique numeric temp file suffix
115 newTempSuffix :: DynFlags -> IO Int
116 newTempSuffix dflags =
117 atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n)
118
119 -- Find a temporary name that doesn't already exist.
120 newTempName :: DynFlags -> TempFileLifetime -> Suffix -> IO FilePath
121 newTempName dflags lifetime extn
122 = do d <- getTempDir dflags
123 findTempName (d </> "ghc_") -- See Note [Deterministic base name]
124 where
125 findTempName :: FilePath -> IO FilePath
126 findTempName prefix
127 = do n <- newTempSuffix dflags
128 let filename = prefix ++ show n <.> extn
129 b <- doesFileExist filename
130 if b then findTempName prefix
131 else do -- clean it up later
132 addFilesToClean dflags lifetime [filename]
133 return filename
134
135 newTempDir :: DynFlags -> IO FilePath
136 newTempDir dflags
137 = do d <- getTempDir dflags
138 findTempDir (d </> "ghc_")
139 where
140 findTempDir :: FilePath -> IO FilePath
141 findTempDir prefix
142 = do n <- newTempSuffix dflags
143 let filename = prefix ++ show n
144 b <- doesDirectoryExist filename
145 if b then findTempDir prefix
146 else do createDirectory filename
147 -- see mkTempDir below; this is wrong: -> consIORef (dirsToClean dflags) filename
148 return filename
149
150 newTempLibName :: DynFlags -> TempFileLifetime -> Suffix
151 -> IO (FilePath, FilePath, String)
152 newTempLibName dflags lifetime extn
153 = do d <- getTempDir dflags
154 findTempName d ("ghc_")
155 where
156 findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)
157 findTempName dir prefix
158 = do n <- newTempSuffix dflags -- See Note [Deterministic base name]
159 let libname = prefix ++ show n
160 filename = dir </> "lib" ++ libname <.> extn
161 b <- doesFileExist filename
162 if b then findTempName dir prefix
163 else do -- clean it up later
164 addFilesToClean dflags lifetime [filename]
165 return (filename, dir, libname)
166
167
168 -- Return our temporary directory within tmp_dir, creating one if we
169 -- don't have one yet.
170 getTempDir :: DynFlags -> IO FilePath
171 getTempDir dflags = do
172 mapping <- readIORef dir_ref
173 case Map.lookup tmp_dir mapping of
174 Nothing -> do
175 pid <- getProcessID
176 let prefix = tmp_dir </> "ghc" ++ show pid ++ "_"
177 mask_ $ mkTempDir prefix
178 Just dir -> return dir
179 where
180 tmp_dir = tmpDir dflags
181 dir_ref = dirsToClean dflags
182
183 mkTempDir :: FilePath -> IO FilePath
184 mkTempDir prefix = do
185 n <- newTempSuffix dflags
186 let our_dir = prefix ++ show n
187
188 -- 1. Speculatively create our new directory.
189 createDirectory our_dir
190
191 -- 2. Update the dirsToClean mapping unless an entry already exists
192 -- (i.e. unless another thread beat us to it).
193 their_dir <- atomicModifyIORef' dir_ref $ \mapping ->
194 case Map.lookup tmp_dir mapping of
195 Just dir -> (mapping, Just dir)
196 Nothing -> (Map.insert tmp_dir our_dir mapping, Nothing)
197
198 -- 3. If there was an existing entry, return it and delete the
199 -- directory we created. Otherwise return the directory we created.
200 case their_dir of
201 Nothing -> do
202 debugTraceMsg dflags 2 $
203 text "Created temporary directory:" <+> text our_dir
204 return our_dir
205 Just dir -> do
206 removeDirectory our_dir
207 return dir
208 `catchIO` \e -> if isAlreadyExistsError e
209 then mkTempDir prefix else ioError e
210
211 {- Note [Deterministic base name]
212 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
213
214 The filename of temporary files, especially the basename of C files, can end
215 up in the output in some form, e.g. as part of linker debug information. In the
216 interest of bit-wise exactly reproducible compilation (#4012), the basename of
217 the temporary file no longer contains random information (it used to contain
218 the process id).
219
220 This is ok, as the temporary directory used contains the pid (see getTempDir).
221 -}
222 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
223 removeTmpDirs dflags ds
224 = traceCmd dflags "Deleting temp dirs"
225 ("Deleting: " ++ unwords ds)
226 (mapM_ (removeWith dflags removeDirectory) ds)
227
228 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
229 removeTmpFiles dflags fs
230 = warnNon $
231 traceCmd dflags "Deleting temp files"
232 ("Deleting: " ++ unwords deletees)
233 (mapM_ (removeWith dflags removeFile) deletees)
234 where
235 -- Flat out refuse to delete files that are likely to be source input
236 -- files (is there a worse bug than having a compiler delete your source
237 -- files?)
238 --
239 -- Deleting source files is a sign of a bug elsewhere, so prominently flag
240 -- the condition.
241 warnNon act
242 | null non_deletees = act
243 | otherwise = do
244 putMsg dflags (text "WARNING - NOT deleting source files:"
245 <+> hsep (map text non_deletees))
246 act
247
248 (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
249
250 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
251 removeWith dflags remover f = remover f `catchIO`
252 (\e ->
253 let msg = if isDoesNotExistError e
254 then text "Warning: deleting non-existent" <+> text f
255 else text "Warning: exception raised when deleting"
256 <+> text f <> colon
257 $$ text (show e)
258 in debugTraceMsg dflags 2 msg
259 )
260
261 #if defined(mingw32_HOST_OS)
262 -- relies on Int == Int32 on Windows
263 foreign import ccall unsafe "_getpid" getProcessID :: IO Int
264 #else
265 getProcessID :: IO Int
266 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
267 #endif
268
269 -- The following three functions are from the `temporary` package.
270
271 -- | Create and use a temporary directory in the system standard temporary
272 -- directory.
273 --
274 -- Behaves exactly the same as 'withTempDirectory', except that the parent
275 -- temporary directory will be that returned by 'getTemporaryDirectory'.
276 withSystemTempDirectory :: String -- ^ Directory name template. See 'openTempFile'.
277 -> (FilePath -> IO a) -- ^ Callback that can use the directory
278 -> IO a
279 withSystemTempDirectory template action =
280 getTemporaryDirectory >>= \tmpDir -> withTempDirectory tmpDir template action
281
282
283 -- | Create and use a temporary directory.
284 --
285 -- Creates a new temporary directory inside the given directory, making use
286 -- of the template. The temp directory is deleted after use. For example:
287 --
288 -- > withTempDirectory "src" "sdist." $ \tmpDir -> do ...
289 --
290 -- The @tmpDir@ will be a new subdirectory of the given directory, e.g.
291 -- @src/sdist.342@.
292 withTempDirectory :: FilePath -- ^ Temp directory to create the directory in
293 -> String -- ^ Directory name template. See 'openTempFile'.
294 -> (FilePath -> IO a) -- ^ Callback that can use the directory
295 -> IO a
296 withTempDirectory targetDir template =
297 Exception.bracket
298 (createTempDirectory targetDir template)
299 (ignoringIOErrors . removeDirectoryRecursive)
300
301 ignoringIOErrors :: IO () -> IO ()
302 ignoringIOErrors ioe = ioe `catch` (\e -> const (return ()) (e :: IOError))
303
304
305 createTempDirectory :: FilePath -> String -> IO FilePath
306 createTempDirectory dir template = do
307 pid <- getProcessID
308 findTempName pid
309 where findTempName x = do
310 let path = dir </> template ++ show x
311 createDirectory path
312 return path
313 `catchIO` \e -> if isAlreadyExistsError e
314 then findTempName (x+1) else ioError e