Repository : ssh://g...@git.haskell.org/process
On branch : master
Link :
http://git.haskell.org/packages/process.git/commitdiff/32223a9ab174c22e939c81e24b6f48223c7cb020
>---------------------------------------------------------------
commit 32223a9ab174c22e939c81e24b6f48223c7cb020
Author: Takano Akio <al...@hyper.cx>
Date: Wed Sep 25 19:37:00 2013 +0900
Fix deadlocks in readProcess{,WithExitCode}
The problem is in the exception handler in readProcess. When it receives
an asynchronous exception, it tries to clean up by closing the pipes.
However the attempt to close outh blocks because the reader thread
(reading with hGetContents) is blocking on the handle.
This fixes #8483.
Signed-off-by: Austin Seipp <aus...@well-typed.com>
>---------------------------------------------------------------
32223a9ab174c22e939c81e24b6f48223c7cb020
System/Process.hs | 8 ++++----
tests/T8343.hs | 8 ++++++++
tests/T8343.stdout | 2 ++
tests/all.T | 2 ++
4 files changed, 16 insertions(+), 4 deletions(-)
diff --git a/System/Process.hs b/System/Process.hs
index 42d2fac..2808339 100644
--- a/System/Process.hs
+++ b/System/Process.hs
@@ -400,8 +400,8 @@ readProcess cmd args input =
std_out = CreatePipe,
std_err = Inherit }
flip onException
- (do hClose inh; hClose outh;
- terminateProcess pid; waitForProcess pid) $ restore $ do
+ (do terminateProcess pid; hClose inh; hClose outh;
+ waitForProcess pid) $ restore $ do
-- fork off a thread to start consuming the output
output <- hGetContents outh
waitOut <- forkWait $ C.evaluate $ rnf output
@@ -457,8 +457,8 @@ readProcessWithExitCode cmd args input =
std_out = CreatePipe,
std_err = CreatePipe }
flip onException
- (do hClose inh; hClose outh; hClose errh;
- terminateProcess pid; waitForProcess pid) $ restore $ do
+ (do terminateProcess pid; hClose inh; hClose outh; hClose errh;
+ waitForProcess pid) $ restore $ do
-- fork off a thread to start consuming stdout
out <- hGetContents outh
waitOut <- forkWait $ C.evaluate $ rnf out
diff --git a/tests/T8343.hs b/tests/T8343.hs
new file mode 100644
index 0000000..23363a5
--- /dev/null
+++ b/tests/T8343.hs
@@ -0,0 +1,8 @@
+import System.Process
+import System.Timeout
+
+main = timeout 1000000 $ do -- The outer timeout shouldn't trigger
+ timeout 10000 $ print =<< readProcess "sleep" ["7200"] ""
+ putStrLn "Good!"
+ timeout 10000 $ print =<< readProcessWithExitCode "sleep" ["7200"] ""
+ putStrLn "Good!"
diff --git a/tests/T8343.stdout b/tests/T8343.stdout
new file mode 100644
index 0000000..75c573d
--- /dev/null
+++ b/tests/T8343.stdout
@@ -0,0 +1,2 @@
+Good!
+Good!
diff --git a/tests/all.T b/tests/all.T
index 3a19367..f77fe8e 100644
--- a/tests/all.T
+++ b/tests/all.T
@@ -32,3 +32,5 @@ test('T4889', normal, compile_and_run, [''])
test('process009', when(opsys('mingw32'), skip), compile_and_run, [''])
test('process010', normal, compile_and_run, [''])
+
+test('T8343', normal, compile_and_run, [''])
_______________________________________________
ghc-commits mailing list
ghc-commits@haskell.org
http://www.haskell.org/mailman/listinfo/ghc-commits
