diff options
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 13 | ||||
| -rw-r--r-- | compiler/utils/Util.hs | 24 |
2 files changed, 29 insertions, 8 deletions
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 3f59ed3bbf..f1ef637037 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1341,7 +1341,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 @@ -1371,15 +1374,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) diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs index 16864fe017..41f63f2246 100644 --- a/compiler/utils/Util.hs +++ b/compiler/utils/Util.hs @@ -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 @@ -1304,6 +1306,26 @@ modificationTimeIfExists f = do 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 -- up (but not including) the last character for which 'pred' returned |