Commit f12fc5cf authored by Tamar Christina's avatar Tamar Christina Committed by Ryan Scott

hsc2hs: fix non-deterministic failures for response file handlings (#29)

* hsc2hs: fix non-deterministic failures for response file handlings

* hsc2hs: simplify cpp

* hsc2hs: add comments on withTempFile
parent 6236b660
......@@ -14,6 +14,7 @@ import System.Process ( createProcess, waitForProcess
, proc, CreateProcess(..), StdStream(..) )
import System.Exit ( ExitCode(..), exitWith )
import System.Directory ( removeFile )
import System.FilePath ( (</>) )
die :: String -> IO a
die s = hPutStr stderr s >> exitWith (ExitFailure 1)
......@@ -27,11 +28,19 @@ default_compiler = "gcc"
writeBinaryFile :: FilePath -> String -> IO ()
writeBinaryFile fp str = withBinaryFile fp WriteMode $ \h -> hPutStr h str
rawSystemL :: FilePath -> String -> Bool -> FilePath -> [String] -> IO ()
rawSystemL outDir action flg prog args = withResponseFile outDir "c2hscall.rsp" args $ \rspFile -> do
rawSystemL :: FilePath -> FilePath -> String -> Bool -> FilePath -> [String] -> IO ()
rawSystemL outDir outBase action flg prog args = withResponseFile outDir outBase args $ \rspFile -> do
let cmdLine = prog++" "++unwords args
when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
(_,_,_,ph) <- createProcess (proc prog ['@':rspFile])
-- Because of the response files being written and removed after the process
-- terminates we now need to use process jobs here to correctly wait for all
-- child processes to terminate. Not doing so would causes a race condition
-- between the last child dieing and not holding a lock on the response file
-- and the response file getting deleted.
#if MIN_VERSION_process (1,5,0)
{ use_process_jobs = True }
#endif
exitStatus <- waitForProcess ph
case exitStatus of
ExitFailure exitCode -> die $ action ++ " failed "
......@@ -40,8 +49,8 @@ rawSystemL outDir action flg prog args = withResponseFile outDir "c2hscall.rsp"
_ -> return ()
rawSystemWithStdOutL :: FilePath -> String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
rawSystemWithStdOutL outDir action flg prog args outFile = withResponseFile outDir "c2hscall.rsp" args $ \rspFile -> do
rawSystemWithStdOutL :: FilePath -> FilePath -> String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
rawSystemWithStdOutL outDir outBase action flg prog args outFile = withResponseFile outDir outBase args $ \rspFile -> do
let cmdLine = prog++" "++unwords args++" >"++outFile
when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
hOut <- openFile outFile WriteMode
......@@ -110,15 +119,22 @@ onlyOne what = die ("Only one "++what++" may be specified\n")
-- response file handling borrowed from cabal's at Distribution.Simple.Program.ResponseFile
withTempFile :: FilePath -- ^ Temp dir to create the file in
-> String -- ^ File name template. See 'openTempFile'.
withTempFile :: FilePath -- ^ Temp dir to create the file in
-> FilePath -- ^ Name of the hsc file being processed
-> (FilePath -> Handle -> IO a) -> IO a
withTempFile tmpDir template action =
withTempFile tmpDir outBase action =
-- openTempFile isn't atomic under Windows until GHC 8.10, this means it's
-- unsuitable for use on Windows for creating random temp files. For hsc2hs
-- this doesn't matter much since hsc2hs is single threaded and always
-- finishes one part of it's compilation pipeline before moving on to the next.
-- This means we can just use a deterministic file as a temp file. This file
-- will always be cleaned up before we move on to the next phase so we would
-- never get a clash. This follows the same pattern as in DirectCodegen.hs.
Exception.bracket
(openTempFile tmpDir template)
(\(name, handle) -> do hClose handle
removeFile $ name)
(uncurry action)
(openFile rspFile ReadWriteMode)
(\handle -> finallyRemove rspFile $ hClose handle)
(action rspFile)
where rspFile = tmpDir </> (outBase ++"_hsc_make.rsp")
withResponseFile ::
FilePath -- ^ Working directory to create response file in.
......@@ -126,8 +142,8 @@ withResponseFile ::
-> [String] -- ^ Arguments to put into response file.
-> (FilePath -> IO a)
-> IO a
withResponseFile workDir fileNameTemplate arguments f =
withTempFile workDir fileNameTemplate $ \responseFileName hf -> do
withResponseFile workDir outBase arguments f =
withTempFile workDir outBase $ \responseFileName hf -> do
let responseContents = unlines $ map escapeResponseFileArg arguments
hPutStr hf responseContents
hClose hf
......
......@@ -73,7 +73,8 @@ outputDirect config outName outDir outBase name toks = do
when (cNoCompile config) $ exitWith ExitSuccess
rawSystemL outDir ("compiling " ++ cProgName) beVerbose (cCompiler config)
rawSystemL outDir outBase ("compiling " ++ cProgName) beVerbose
(cCompiler config)
( ["-c"]
++ [cProgName]
++ ["-o", oProgName]
......@@ -82,14 +83,15 @@ outputDirect config outName outDir outBase name toks = do
possiblyRemove cProgName $
withUtilsObject config outDir outBase $ \oUtilsName -> do
rawSystemL outDir ("linking " ++ oProgName) beVerbose (cLinker config)
rawSystemL outDir outBase ("linking " ++ oProgName) beVerbose
(cLinker config)
( [oProgName, oUtilsName]
++ ["-o", progName]
++ [f | LinkFlag f <- flags]
)
possiblyRemove oProgName $ do
rawSystemWithStdOutL outDir ("running " ++ execProgName) beVerbose execProgName [] outName
rawSystemWithStdOutL outDir outBase ("running " ++ execProgName) beVerbose execProgName [] outName
possiblyRemove progName $ do
when needsH $ writeBinaryFile outHName $
......
......@@ -79,7 +79,7 @@ withUtilsObject config outDir outBase f = do
possiblyRemove oUtilsName $ do
unless (cNoCompile config) $
rawSystemL outDir ("compiling " ++ cUtilsName)
rawSystemL outDir outBase ("compiling " ++ cUtilsName)
beVerbose
(cCompiler config)
(["-c", cUtilsName, "-o", oUtilsName] ++
......
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