From 9aace0eaf6279f17368a1753b65afbdc466e8291 Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Sat, 10 Apr 2021 14:48:16 +0200
Subject: [PATCH] Produce constant file atomically (#19684)

---
 utils/deriveConstants/Main.hs               | 21 ++++++++++++++++-----
 utils/deriveConstants/deriveConstants.cabal |  3 ++-
 2 files changed, 18 insertions(+), 6 deletions(-)

diff --git a/utils/deriveConstants/Main.hs b/utils/deriveConstants/Main.hs
index 8bf8ae7b44d..9db673a9852 100644
--- a/utils/deriveConstants/Main.hs
+++ b/utils/deriveConstants/Main.hs
@@ -34,9 +34,10 @@ import Data.Maybe (catMaybes, mapMaybe, fromMaybe)
 import Numeric (readHex)
 import System.Environment (getArgs)
 import System.Exit (ExitCode(ExitSuccess), exitFailure)
-import System.FilePath ((</>))
+import System.FilePath ((</>),(<.>))
 import System.IO (stderr, hPutStrLn)
 import System.Process (showCommandForUser, readProcess, rawSystem)
+import System.Directory (renameFile)
 
 main :: IO ()
 main = do opts <- parseArgs
@@ -79,6 +80,16 @@ data Options = Options {
                    o_targetOS :: Maybe String
                }
 
+-- | Write a file atomically
+--
+-- This avoids other processes seeing the file while it is being written into.
+atomicWriteFile :: FilePath -> String -> IO ()
+atomicWriteFile fn s = do
+  let tmp = fn <.> "tmp"
+  writeFile tmp s
+  renameFile tmp fn
+
+
 parseArgs :: IO Options
 parseArgs = do args <- getArgs
                opts <- f emptyOptions args
@@ -670,7 +681,7 @@ getWanted verbose os tmpdir gccProgram gccFlags nmProgram mobjdumpProgram
     = do let cStuff = unlines (headers ++ concatMap (doWanted . snd) (wanteds os))
              cFile = tmpdir </> "tmp.c"
              oFile = tmpdir </> "tmp.o"
-         writeFile cFile cStuff
+         atomicWriteFile cFile cStuff
          execute verbose gccProgram (gccFlags ++ ["-c", cFile, "-o", oFile])
          xs <- case os of
                  "openbsd" -> readProcess objdumpProgam ["--syms", oFile] ""
@@ -855,7 +866,7 @@ getWanted verbose os tmpdir gccProgram gccFlags nmProgram mobjdumpProgram
               = return (w, FieldTypeGcptrMacro name)
 
 writeHaskellType :: FilePath -> [What Fst] -> IO ()
-writeHaskellType fn ws = writeFile fn xs
+writeHaskellType fn ws = atomicWriteFile fn xs
     where xs = unlines [header, body, footer, parser]
           header = "module GHC.Platform.Constants where\n\n\
                    \import Prelude\n\
@@ -920,7 +931,7 @@ writeHaskellType fn ws = writeFile fn xs
 
 
 writeHaskellValue :: FilePath -> [What Snd] -> IO ()
-writeHaskellValue fn rs = writeFile fn xs
+writeHaskellValue fn rs = atomicWriteFile fn xs
     where xs = unlines [header, body, footer]
           header = "PlatformConstants {"
           footer = "  }"
@@ -937,7 +948,7 @@ writeHaskellValue fn rs = writeFile fn xs
           doWhat (FieldTypeGcptrMacro {}) = []
 
 writeHeader :: FilePath -> [(Where, What Snd)] -> IO ()
-writeHeader fn rs = writeFile fn xs
+writeHeader fn rs = atomicWriteFile fn xs
     where xs = headers ++ hs ++ unlines body
           headers = "/* This file is created automatically.  Do not edit by hand.*/\n\n"
           haskellRs = fmap snd $ filter (\r -> fst r `elem` [Haskell,Both]) rs
diff --git a/utils/deriveConstants/deriveConstants.cabal b/utils/deriveConstants/deriveConstants.cabal
index 50b5b695c30..36ba7ebe1f7 100644
--- a/utils/deriveConstants/deriveConstants.cabal
+++ b/utils/deriveConstants/deriveConstants.cabal
@@ -20,4 +20,5 @@ Executable deriveConstants
     Build-Depends: base       >= 4   && < 5,
                    containers,
                    process,
-                   filepath
+                   filepath,
+                   directory
-- 
GitLab