SysTools.Process: Handle exceptions in readCreateProcessWithExitCode'

In #18069 we are observing MVar deadlocks from somewhere in ghc.exe.
This use of MVar stood out as being one of the more likely culprits.
Here we make sure that it is exception-safe.

1 files changed, 18 insertions, 3 deletions

diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs
index d09a3bd09c..009723f795 100644
--- a/compiler/GHC/SysTools/Process.hs
+++ b/compiler/GHC/SysTools/Process.hs
@@ -45,6 +45,15 @@ enableProcessJobs opts = opts
 enableProcessJobs opts = opts
 #endif
 
+#if !MIN_VERSION_base(4,15,0)
+-- TODO: This can be dropped with GHC 8.16
+hGetContents' :: Handle -> IO String
+hGetContents' hdl = do
+  output  <- hGetContents hdl
+  _ <- evaluate $ length output
+  return output
+#endif
+
 -- Similar to System.Process.readCreateProcessWithExitCode, but stderr is
 -- inherited from the parent process, and output to stderr is not captured.
 readCreateProcessWithExitCode'
@@ -55,13 +64,19 @@ readCreateProcessWithExitCode' proc = do
         createProcess $ enableProcessJobs $ proc{ std_out = CreatePipe }
 
     -- fork off a thread to start consuming the output
-    output  <- hGetContents outh
     outMVar <- newEmptyMVar
-    _ <- forkIO $ evaluate (length output) >> putMVar outMVar ()
+    let onError :: SomeException -> IO ()
+        onError exc = putMVar outMVar (Left exc)
+    _ <- forkIO $ handle onError $ do
+      output <- hGetContents' outh
+      putMVar outMVar $ Right output
 
     -- wait on the output
-    takeMVar outMVar
+    result <- takeMVar outMVar
     hClose outh
+    output <- case result of
+      Left exc -> throwIO exc
+      Right output -> return output
 
     -- wait on the process
     ex <- waitForProcess pid