From d0bab2e3419e49cdbb1201d4650572b57f33420c Mon Sep 17 00:00:00 2001
From: Tamar Christina <tamar@zhox.com>
Date: Wed, 25 Dec 2019 12:06:28 +0000
Subject: [PATCH] SysTools: Use "process job" when spawning processes on
Windows
GHC should make calls using process jobs when calling out to GCC and LD.
The reason is these use the exec () family of posix functions. Window's
process model doesn't allow replacement of processes so this is emulated
by creating a new process and immediately exiting the old one. Because
of this when using normal Windows wait functions you would return even
without the child process having finished. In this case if you are
depending on data from the child you will enter a race condition.
The usual fix for this is to use process jobs and wait for the
termination of all children that have ever been spawn by the process you
called. But also waiting for the freeing of all resources.
(cherry picked from commit 584eee71f803ebf59f12758755151110a6e8636f)
---
compiler/main/SysTools/Process.hs | 19 ++++++++++++++++---
1 file changed, 16 insertions(+), 3 deletions(-)
diff --git a/compiler/main/SysTools/Process.hs b/compiler/main/SysTools/Process.hs
index bead5a608b07..140ea2193bfb 100644
--- a/compiler/main/SysTools/Process.hs
+++ b/compiler/main/SysTools/Process.hs
@@ -68,7 +68,7 @@ readProcessEnvWithExitCode
-> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr)
readProcessEnvWithExitCode prog args env_update = do
current_env <- getEnvironment
- readCreateProcessWithExitCode (proc prog args) {
+ readCreateProcessWithExitCode ((proc prog args) {use_process_jobs = True}) {
env = Just (replaceVar env_update current_env) } ""
-- Don't let gcc localize version info string, #8825
@@ -220,8 +220,21 @@ builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do
-- unless an exception was raised.
let safely inner = mask $ \restore -> do
-- acquire
- (hStdIn, hStdOut, hStdErr, hProcess) <- restore $
- runInteractiveProcess pgm real_args mb_cwd mb_env
+ -- On Windows due to how exec is emulated the old process will exit and
+ -- a new process will be created. This means waiting for termination of
+ -- the parent process will get you in a race condition as the child may
+ -- not have finished yet. This caused #16450. To fix this use a
+ -- process job to track all child processes and wait for each one to
+ -- finish.
+ let procdata = (proc pgm real_args) { cwd = mb_cwd
+ , env = mb_env
+ , use_process_jobs = True
+ , std_in = CreatePipe
+ , std_out = CreatePipe
+ , std_err = CreatePipe
+ }
+ (Just hStdIn, Just hStdOut, Just hStdErr, hProcess) <- restore $
+ createProcess_ "builderMainLoop" procdata
let cleanup_handles = do
hClose hStdIn
hClose hStdOut
--
GitLab