Commit 08ad38a9 authored by Niklas Hambüchen's avatar Niklas Hambüchen Committed by Marge Bot

compiler: Refactor: extract `withAtomicRename`

parent cfbedf17
Pipeline #3289 passed with stages
in 241 minutes and 40 seconds
......@@ -1305,7 +1305,10 @@ runPhase (RealPhase (As with_cpp)) input_fn dflags
let local_includes = [ SysTools.Option ("-iquote" ++ p)
| p <- includePathsQuote cmdline_include_paths ]
let runAssembler inputFilename outputFilename
= liftIO $ as_prog dflags
= liftIO $ do
withAtomicRename outputFilename $ \temp_outputFilename -> do
as_prog
dflags
(local_includes ++ global_includes
-- See Note [-fPIC for assembler]
++ map SysTools.Option pic_c_flags
......@@ -1335,15 +1338,11 @@ runPhase (RealPhase (As with_cpp)) input_fn dflags
, SysTools.Option "-c"
, SysTools.FileOption "" inputFilename
, SysTools.Option "-o"
, SysTools.FileOption "" outputFilename
, SysTools.FileOption "" temp_outputFilename
])
liftIO $ debugTraceMsg dflags 4 (text "Running the assembler")
-- Atomic write by writing to temp file and then renaming
let temp_output_fn = output_fn <.> "tmp"
runAssembler input_fn temp_output_fn
liftIO $ renameFile temp_output_fn output_fn
runAssembler input_fn output_fn
return (RealPhase next_phase, output_fn)
......
......@@ -99,6 +99,7 @@ module Util (
doesDirNameExist,
getModificationUTCTime,
modificationTimeIfExists,
withAtomicRename,
global, consIORef, globalM,
sharedGlobal, sharedGlobalM,
......@@ -145,9 +146,10 @@ import GHC.Stack (HasCallStack)
import Control.Applicative ( liftA2 )
import Control.Monad ( liftM, guard )
import Control.Monad.IO.Class ( MonadIO, liftIO )
import GHC.Conc.Sync ( sharedCAF )
import System.IO.Error as IO ( isDoesNotExistError )
import System.Directory ( doesDirectoryExist, getModificationTime )
import System.Directory ( doesDirectoryExist, getModificationTime, renameFile )
import System.FilePath
import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper
......@@ -1303,6 +1305,26 @@ modificationTimeIfExists f = do
then return Nothing
else ioError e
-- --------------------------------------------------------------
-- atomic file writing by writing to a temporary file first (see #14533)
--
-- This should be used in all cases where GHC writes files to disk
-- and uses their modification time to skip work later,
-- as otherwise a partially written file (e.g. due to crash or Ctrl+C)
-- also results in a skip.
withAtomicRename :: (MonadIO m) => FilePath -> (FilePath -> m a) -> m a
withAtomicRename targetFile f = do
-- The temp file must be on the same file system (mount) as the target file
-- to result in an atomic move on most platforms.
-- The standard way to ensure that is to place it into the same directory.
-- This can still be fooled when somebody mounts a different file system
-- at just the right time, but that is not a case we aim to cover here.
let temp = targetFile <.> "tmp"
res <- f temp
liftIO $ renameFile temp targetFile
return res
-- --------------------------------------------------------------
-- split a string at the last character where 'pred' is True,
-- returning a pair of strings. The first component holds the string
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment