summaryrefslogtreecommitdiff
path: root/compiler/GHC/SysTools
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2020-05-19 13:02:21 -0400
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-08-25 07:37:05 -0400
commit0a1ecc5fd45a46372c3935df596f05432db1b270 (patch)
tree4d516115170b7daefdd91693b586b5449265af18 /compiler/GHC/SysTools
parent05550a5abc369e1cc4fc48def532ca9ba9adcad7 (diff)
downloadhaskell-0a1ecc5fd45a46372c3935df596f05432db1b270.tar.gz
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.
Diffstat (limited to 'compiler/GHC/SysTools')
-rw-r--r--compiler/GHC/SysTools/Process.hs21
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