Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 72c55eee by Cheng Shao at 2026-07-28T16:43:11-04:00 hadrian: implement and use writeFileAtomic to fix race condition This patch implements `writeFileAtomic` in hadrian and change all invocations of shake non-atomic `writeFile'` to use `writeFileAtomic`, to avoid multiple hadrian concurrent invocations overwriting the same in-tree generated file not in the build root directory. Fixes #27536. Additional notes: - `writeFileChanged`/`writeFileChangedBS` cannot be made atomic since it involves reading the file's older version, so their uses are left alone. It doesn't affect #27536 given their outputs are contained in the build root directory. - It's possible to shrink this patch by only making writes outside the build root directory atomic. But I think it's not worth the effort for fine grained distinction here, and atomic writes within the build root directory should also improve robustness of a hadrian build. - In the longer term we do want to make a ghc build only generate files within the build root directory, though that's a lot of work and outside the scope of this particular bugfix. Co-authored-by: Codex <codex@openai.com> - - - - - 14 changed files: - hadrian/src/Hadrian/Builder/Ar.hs - hadrian/src/Hadrian/Utilities.hs - hadrian/src/Rules/BinaryDist.hs - hadrian/src/Rules/CabalReinstall.hs - hadrian/src/Rules/Documentation.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Rules/Library.hs - hadrian/src/Rules/Nofib.hs - hadrian/src/Rules/Program.hs - hadrian/src/Rules/Register.hs - hadrian/src/Rules/Rts.hs - hadrian/src/Rules/SourceDist.hs - hadrian/src/Rules/Test.hs - hadrian/src/Rules/ToolArgs.hs Changes: ===================================== hadrian/src/Hadrian/Builder/Ar.hs ===================================== @@ -43,7 +43,7 @@ runAr :: FilePath -- ^ base name to use for response files -> Action () runAr outputFilePath arPath flagArgs fileArgs buildOptions = do rspFile <- responseFilePath outputFilePath - writeFile' rspFile $ unwords fileArgs + writeFileAtomic rspFile $ unwords fileArgs cmd [arPath] flagArgs ('@' : rspFile) buildOptions -- | Invoke @ar@ given a path to it and a list of arguments. Note that @ar@ ===================================== hadrian/src/Hadrian/Utilities.hs ===================================== @@ -21,7 +21,9 @@ module Hadrian.Utilities ( -- * File system operations copyFile, copyFileUntracked, createFileLink, fixFile, makeExecutable, moveFile, removeFile, createDirectory, copyDirectory, - moveDirectory, removeDirectory, removeFile_, writeFileChangedBS, + moveDirectory, removeDirectory, removeFile_, + writeFileAtomic, writeFileLinesAtomic, + writeFileChangedBS, -- * Diagnostic info Colour (..), ANSIColour (..), putColoured, shouldUseColor, @@ -48,6 +50,7 @@ import Data.List.Extra import Data.Maybe import Data.Typeable (TypeRep, typeOf) import Development.Shake hiding (Normal) +import qualified Development.Shake as Shake import Development.Shake.Classes import Development.Shake.Command (CmdArgument (..), IsCmdArgument (toCmdArgument)) import Development.Shake.FilePath @@ -341,7 +344,7 @@ withResponseFileIfLongCmd outputFilePath argsPre argsResp argsPost = do then cmd argsPre argsResp argsPost else do rspFile <- responseFilePath outputFilePath - writeFile' rspFile (escapeArgs argsResp) + writeFileAtomic rspFile (escapeArgs argsResp) cmd argsPre ['@' : rspFile] argsPost -- | Convert a command's output file path to a response file path to be used for that command. @@ -400,6 +403,19 @@ copyFileUntracked source target = do putProgressInfo =<< renderAction "Copy file (untracked)" source target liftIO $ IO.copyFile source target +-- | An atomic version of Shake's 'Shake.writeFile''. +writeFileAtomic :: FilePath -> String -> Action () +writeFileAtomic file contents = do + let dir = takeDirectory file + liftIO $ IO.createDirectoryIfMissing True dir + withTempFileWithin dir $ \temp -> do + Shake.writeFile' temp contents + liftIO $ IO.renameFile temp file + +-- | An atomic version of Shake's 'Shake.writeFileLines'. +writeFileLinesAtomic :: FilePath -> [String] -> Action () +writeFileLinesAtomic file = writeFileAtomic file . unlines + -- | Transform a given file by applying a function to its contents. fixFile :: FilePath -> (String -> String) -> Action () fixFile file f = do @@ -409,7 +425,7 @@ fixFile file f = do let new = f old IO.evaluate $ rnf new return new - liftIO $ writeFile file contents + writeFileAtomic file contents -- | Make a given file executable by running the @chmod +x@ command. makeExecutable :: FilePath -> Action () ===================================== hadrian/src/Rules/BinaryDist.hs ===================================== @@ -234,7 +234,7 @@ buildBinDistDir root conf@BindistConfig{..} = do bindistContext = vanillaContext library_stage compiler bindistSettingsContent <- interpretInContext bindistContext $ generateSettings bindistSettings False "package.conf.d" - writeFile' bindistSettings bindistSettingsContent + writeFileAtomic bindistSettings bindistSettingsContent copyDirectory rtsIncludeDir bindistFilesDir when windowsHost $ createGhcii (bindistFilesDir -/- "bin") @@ -296,7 +296,7 @@ buildBinDistDir root conf@BindistConfig{..} = do need $ map (bindistFilesDir -/-) (["configure", "Makefile"] ++ bindistInstallFiles) copyFile ("hadrian" -/- "bindist" -/- "config.mk.in") (bindistFilesDir -/- "config.mk.in") - generateBuildMk conf >>= writeFile' (bindistFilesDir -/- "build.mk") + generateBuildMk conf >>= writeFileAtomic (bindistFilesDir -/- "build.mk") copyFile ("hadrian" -/- "cfg" -/- "default.target.in") (bindistFilesDir -/- "default.target.in") copyFile ("hadrian" -/- "cfg" -/- "default.host.target.in") (bindistFilesDir -/- "default.host.target.in") @@ -314,7 +314,7 @@ buildBinDistDir root conf@BindistConfig{..} = do versioned_wrapper = wrapper_name ++ "-" ++ suffix versioned_wrapper_path = bindistFilesDir -/- "wrappers" -/- versioned_wrapper -- Write the wrapper to the versioned path - writeFile' versioned_wrapper_path wrapper_content + writeFileAtomic versioned_wrapper_path wrapper_content -- Create a symlink from the non-versioned to the versioned. liftIO $ do IO.removeFile unversioned_wrapper_path <|> return () ===================================== hadrian/src/Rules/CabalReinstall.hs ===================================== @@ -38,7 +38,7 @@ cabalBuildRules = do withVerbosity Diagnostic $ buildWithCmdOptions [] $ target (vanillaContext Stage2 pkg) (Cabal Install Stage2) [] [] - liftIO $ writeFile outpath "done" + writeFileAtomic outpath "done" phony "build-cabal" $ need [root -/- "stage-cabal" -/- "bin" -/- ".stamp"] @@ -86,8 +86,8 @@ cabalBuildRules = do ] output_file = outputDir -/- wrapper_name wrapper_content <- wrapper Stage2 wrapper_name - writeFile' output_file (wrapper_prefix ++ wrapper_content) + writeFileAtomic output_file (wrapper_prefix ++ wrapper_content) makeExecutable output_file pure () - writeFile' stamp "OK" + writeFileAtomic stamp "OK" ===================================== hadrian/src/Rules/Documentation.hs ===================================== @@ -268,7 +268,7 @@ buildPackageDocumentation = do syn <- pkgSynopsis (Context.package ctx) desc <- pkgDescription (Context.package ctx) let prologue = if null desc then syn else desc - liftIO $ writeFile file prologue + writeFileAtomic file prologue root -/- htmlRoot -/- "libraries/*/*.haddock" %> \file -> do context <- pkgDocContext =<< getPkgDocTarget root file ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -353,7 +353,7 @@ templateRuleFrom inPath outPath interps = do outPath %> \_ -> do s <- readFile' inPath result <- runInterpolations interps s - writeFile' outPath result + writeFileAtomic outPath result putSuccess ("| Successfully generated " ++ outPath ++ " from its template") templateRule :: FilePath -> Interpolations -> Rules () ===================================== hadrian/src/Rules/Library.hs ===================================== @@ -140,7 +140,7 @@ buildPackage root fp = do -- Write the current time into the file so the file always changes if -- we restamp it because a dependency changes. time <- liftIO $ getCurrentTime - liftIO $ writeFile fp (show time) + writeFileAtomic fp (show time) ways <- interpretInContext ctx getLibraryWays let hasVanilla = elem vanilla ways hasDynamic = elem dynamic ways @@ -148,7 +148,7 @@ buildPackage root fp = do when ((hasVanilla && hasDynamic) && support && way == vanilla) $ do stamp <- (pkgStampFile (ctx { way = dynamic })) - liftIO $ writeFile stamp (show time) + writeFileAtomic stamp (show time) ===================================== hadrian/src/Rules/Nofib.hs ===================================== @@ -42,7 +42,7 @@ nofibRules = do unit $ cmd (Cwd "nofib") [makePath] ["clean"] unit $ cmd (Cwd "nofib") [makePath] (nofibArgs ++ ["boot"]) (Exit e, Stdouterr log) <- cmd (Cwd "nofib") [makePath] nofibArgs - writeFile' fp log + writeFileAtomic fp log if e == ExitSuccess then putVerbose $ "nofib log available at " ++ fp else error $ "nofib failed, full log available at " ++ fp ===================================== hadrian/src/Rules/Program.hs ===================================== @@ -32,7 +32,7 @@ buildProgramRules rs = do top <- topDirectory need [ top -/- "configure" ] copyDirectory (top -/- "inplace" -/- "mingw") root - writeFile' stampPath "OK" + writeFileAtomic stampPath "OK" -- Rules for programs that are actually built by hadrian. forM_ allStages $ \stage -> ===================================== hadrian/src/Rules/Register.hs ===================================== @@ -94,7 +94,7 @@ registerPackageRules rs stage iplace = do -- leads to errors in GHC). buildWithResources rs $ target (Context stage compiler vanilla iplace) (GhcPkg Recache stage) [] [] - writeFileLines stamp [] + writeFileLinesAtomic stamp [] -- Special rule for registering system-cxx-std-lib root -/- relativePackageDbPath (PackageDbLoc stage iplace) -/- systemCxxStdLibConf %> \file -> do ===================================== hadrian/src/Rules/Rts.hs ===================================== @@ -21,7 +21,7 @@ buildGhcInternalImportDef target = do templateIn <- readFile' "rts/win32/libHSghc-internal.def.in" let dllName = takeFileName target -<.> "dll" templateOut = replace "@GhcInternalDll@" dllName templateIn - writeFile' target templateOut + writeFileAtomic target templateOut buildGhcInternalImportLib :: Stage -> FilePath -> Action () buildGhcInternalImportLib stg target = do ===================================== hadrian/src/Rules/SourceDist.hs ===================================== @@ -36,7 +36,7 @@ sourceDistRules = alternatives $ do need [mingw_tarballs_stamp] mingw_tarballs_stamp %> \stamp -> do build (target (vanillaContext Stage1 compiler) (Win32Tarballs DownloadTarballs) [] []) - writeFile' stamp "OK" + writeFileAtomic stamp "OK" archiveSourceTree :: (FilePath -> Action ()) -> FilePath -> Action () ===================================== hadrian/src/Rules/Test.hs ===================================== @@ -328,7 +328,7 @@ timeoutProgBuilder = do let script = unlines [ "#!/bin/sh" , "exec " ++ python ++ " $0.py \"$@\"" ] - writeFile' (root -/- timeoutPath) script + writeFileAtomic (root -/- timeoutPath) script makeExecutable (root -/- timeoutPath) -- | Build extra programs and libraries required by testsuite ===================================== hadrian/src/Rules/ToolArgs.hs ===================================== @@ -63,7 +63,7 @@ multiSetup pkg_s = do -- Get the arguments for all the targets pargs <- mapM one_args tool_targets -- Build any other dependencies (such as generated files) - liftIO $ writeOutput (concatMap (\x -> ["-unit", x]) (map ( "@" <>) pargs)) + writeOutput (concatMap (\x -> ["-unit", x]) (map ( "@" <>) pargs)) where resp_file root p = root </> "multi" </> pkgName p @@ -96,7 +96,7 @@ multiSetup pkg_s = do normalisePackageIds (x:xs) = x : normalisePackageIds xs normalisePackageIds [] = [] - writeFile' (resp_file root p) (intercalate "\n" (normalise_ghc arg_list + writeFileAtomic (resp_file root p) (intercalate "\n" (normalise_ghc arg_list ++ modules cd ++ concatMap rexp (reexportModules cd) ++ ["-outputdir", hidir, @@ -112,11 +112,12 @@ toolRuleBody fp = do Just (_, (p, extra)) -> mkToolTarget extra p Nothing -> fail $ "No prefixes matched " ++ show fp ++ " IN\n " ++ show mm -writeOutput :: [String] -> IO () +writeOutput :: [String] -> Action () writeOutput args = do - liftIO $ lookupEnv "TOOL_OUTPUT" >>= \case - Nothing -> putStrLn (intercalate "\n" args) - Just out -> writeFile out (intercalate "\n" args) + output <- liftIO $ lookupEnv "TOOL_OUTPUT" + case output of + Nothing -> liftIO $ putStrLn (intercalate "\n" args) + Just out -> writeFileAtomic out (intercalate "\n" args) mkToolTarget :: [String] -> Package -> Action () mkToolTarget es p = do @@ -138,7 +139,7 @@ mkToolTarget es p = do need (gens ++ srcs ++ dep_confs) arg_list <- interpret fake_target getArgs - liftIO $ writeOutput (arg_list ++ es) + writeOutput (arg_list ++ es) -- This list is quite a lot like stage0packages but doesn't include -- critically the `exe:ghc` component as that depends on the GHC library @@ -200,4 +201,3 @@ dirMap = do cd <- readContextData c ids <- liftIO $ mapM canonicalizePath [pkgPath p </> i | i <- srcDirs cd] return $ map (,(p, modules cd ++ otherModules cd)) ids - View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/72c55eee0160af1d408c45c551051f99... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/72c55eee0160af1d408c45c551051f99... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help