From 5b99d45103d1edf6f596c353f548221d897db4cf Mon Sep 17 00:00:00 2001 From: Charles Cooper Date: Sat, 2 Apr 2016 17:42:56 -0400 Subject: [PATCH 1/9] Fix bug in multi-threaded waitForProcess Previously an exception was being thrown when multiple threads were blocking on waitForProcess due to inconsistent handling of the return code of `waitpid`: "If more than one thread is suspended in waitpid() awaiting termination of the same process, exactly one thread returns the process status at the time of the target child process termination. The other threads return -1, with errno set to ECHILD." `getProcessExitCode` was handling the ECHILD case by returning 1, but `waitForProcess` was returning (-1) in all cases. For consistency this commit follows the approach in getProcessExitCode, returning 1 to the caller of c_waitForProcess if errno is ECHILD, thus avoiding throwing an exception in the calling code. --- cbits/runProcess.c | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/cbits/runProcess.c b/cbits/runProcess.c index ae184c82..1e97ad15 100644 --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -425,6 +425,11 @@ int waitForProcess (ProcHandle handle, int *pret) if (waitpid(handle, &wstat, 0) < 0) { + if (errno == ECHILD) + { + *pret = 0; + return 1; + } return -1; } From 4575acb4919f24c95b14e346e32daa1103147791 Mon Sep 17 00:00:00 2001 From: Charles Cooper Date: Fri, 3 Feb 2017 10:09:20 -0500 Subject: [PATCH 2/9] Revert "Fix bug in multi-threaded waitForProcess" This reverts commit d67484fe64a9a42e7daf944a9396b4ec46c060f3. --- cbits/runProcess.c | 5 ----- 1 file changed, 5 deletions(-) diff --git a/cbits/runProcess.c b/cbits/runProcess.c index 1e97ad15..ae184c82 100644 --- a/cbits/runProcess.c +++ b/cbits/runProcess.c @@ -425,11 +425,6 @@ int waitForProcess (ProcHandle handle, int *pret) if (waitpid(handle, &wstat, 0) < 0) { - if (errno == ECHILD) - { - *pret = 0; - return 1; - } return -1; } From 962d5f14d2bb4fda38d8bba689952076a3080213 Mon Sep 17 00:00:00 2001 From: Charles Cooper Date: Fri, 3 Feb 2017 10:33:05 -0500 Subject: [PATCH 3/9] Test multithreaded bug --- process.cabal | 2 ++ test/main.hs | 15 ++++++++++++++- 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/process.cabal b/process.cabal index 0ef5b914..30d25bbb 100644 --- a/process.cabal +++ b/process.cabal @@ -82,3 +82,5 @@ test-suite test , bytestring , directory , process + ghc-options: -threaded + -with-rtsopts "-N" diff --git a/test/main.hs b/test/main.hs index 9ea05242..f89f3ef2 100644 --- a/test/main.hs +++ b/test/main.hs @@ -1,10 +1,12 @@ import Control.Exception -import Control.Monad (unless) +import Control.Monad (unless, void) import System.Exit import System.IO.Error import System.Directory (getCurrentDirectory, setCurrentDirectory) import System.Process +import Control.Concurrent import Data.List (isInfixOf) +import Data.Maybe (isNothing) import System.IO (hClose, openBinaryTempFile) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 @@ -66,6 +68,17 @@ main = do unless (bs == res') $ error $ "Unexpected result: " ++ show res' + do -- multithreaded waitForProcess + (_, _, _, p) <- createProcess (proc "sleep" ["0.1"]) + me1 <- newEmptyMVar + forkIO . void $ waitForProcess p >>= putMVar me1 + -- check for race / deadlock between waitForProcess and getProcessExitCode + e3 <- getProcessExitCode p + e2 <- waitForProcess p + e1 <- readMVar me1 + unless (isNothing e3 && e1 == ExitSuccess && e2 == ExitSuccess) + $ error "sleep exited with non-zero exit code!" + putStrLn "Tests passed successfully" withCurrentDirectory :: FilePath -> IO a -> IO a From d837c95d378c16e74d2dcbb09a75ca907eb018d1 Mon Sep 17 00:00:00 2001 From: Charles Cooper Date: Fri, 3 Feb 2017 10:41:05 -0500 Subject: [PATCH 4/9] Fix waitpid race by adding a lock --- System/Process.hs | 12 +++++------- System/Process/Common.hs | 10 +++++++--- System/Process/Posix.hs | 3 ++- 3 files changed, 14 insertions(+), 11 deletions(-) diff --git a/System/Process.hs b/System/Process.hs index 81a5788c..b78b8315 100644 --- a/System/Process.hs +++ b/System/Process.hs @@ -237,7 +237,7 @@ withCreateProcess_ fun c action = cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () cleanupProcess (mb_stdin, mb_stdout, mb_stderr, - ph@(ProcessHandle _ delegating_ctlc)) = do + ph@(ProcessHandle _ delegating_ctlc _)) = do terminateProcess ph -- Note, it's important that other threads that might be reading/writing -- these handles also get killed off, since otherwise they might be holding @@ -258,7 +258,7 @@ cleanupProcess (mb_stdin, mb_stdout, mb_stderr, _ <- forkIO (waitForProcess (resetCtlcDelegation ph) >> return ()) return () where - resetCtlcDelegation (ProcessHandle m _) = ProcessHandle m False + resetCtlcDelegation (ProcessHandle m _ l) = ProcessHandle m False l -- ---------------------------------------------------------------------------- -- spawnProcess/spawnCommand @@ -584,14 +584,11 @@ detail. waitForProcess :: ProcessHandle -> IO ExitCode -waitForProcess ph@(ProcessHandle _ delegating_ctlc) = do +waitForProcess ph@(ProcessHandle _ delegating_ctlc _) = lockWaitpid $ do p_ <- modifyProcessHandle ph $ \p_ -> return (p_,p_) case p_ of ClosedHandle e -> return e OpenHandle h -> do - -- don't hold the MVar while we call c_waitForProcess... - -- (XXX but there's a small race window here during which another - -- thread could close the handle or call waitForProcess) e <- alloca $ \pret -> do throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret) modifyProcessHandle ph $ \p_' -> @@ -616,6 +613,7 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc) = do #else return $ ExitFailure (-1) #endif + where lockWaitpid m = withMVar (waitpidLock ph) $ \() -> m -- ---------------------------------------------------------------------------- -- getProcessExitCode @@ -630,7 +628,7 @@ when the process died as the result of a signal. -} getProcessExitCode :: ProcessHandle -> IO (Maybe ExitCode) -getProcessExitCode ph@(ProcessHandle _ delegating_ctlc) = do +getProcessExitCode ph@(ProcessHandle _ delegating_ctlc _) = do (m_e, was_open) <- modifyProcessHandle ph $ \p_ -> case p_ of ClosedHandle e -> return (p_, (Just e, False)) diff --git a/System/Process/Common.hs b/System/Process/Common.hs index 3c8d3707..dd09c0ed 100644 --- a/System/Process/Common.hs +++ b/System/Process/Common.hs @@ -177,7 +177,11 @@ data StdStream data ProcessHandle__ = OpenHandle PHANDLE | OpenExtHandle PHANDLE PHANDLE PHANDLE | ClosedHandle ExitCode -data ProcessHandle = ProcessHandle !(MVar ProcessHandle__) !Bool +data ProcessHandle + = ProcessHandle { phandle :: !(MVar ProcessHandle__) + , mb_delegate_ctlc :: !Bool + , waitpidLock :: !(MVar ()) + } withFilePathException :: FilePath -> IO a -> IO a withFilePathException fpath act = handle mapEx act @@ -188,13 +192,13 @@ modifyProcessHandle :: ProcessHandle -> (ProcessHandle__ -> IO (ProcessHandle__, a)) -> IO a -modifyProcessHandle (ProcessHandle m _) io = modifyMVar m io +modifyProcessHandle (ProcessHandle m _ _) io = modifyMVar m io withProcessHandle :: ProcessHandle -> (ProcessHandle__ -> IO a) -> IO a -withProcessHandle (ProcessHandle m _) io = withMVar m io +withProcessHandle (ProcessHandle m _ _) io = withMVar m io fd_stdin, fd_stdout, fd_stderr :: FD fd_stdin = 0 diff --git a/System/Process/Posix.hs b/System/Process/Posix.hs index cd8573f4..129072fd 100644 --- a/System/Process/Posix.hs +++ b/System/Process/Posix.hs @@ -48,7 +48,8 @@ import System.Process.Common mkProcessHandle :: PHANDLE -> Bool -> IO ProcessHandle mkProcessHandle p mb_delegate_ctlc = do m <- newMVar (OpenHandle p) - return (ProcessHandle m mb_delegate_ctlc) + l <- newMVar () + return (ProcessHandle m mb_delegate_ctlc l) closePHANDLE :: PHANDLE -> IO () closePHANDLE _ = return () From b2360d9f2260df494c8ddb90db6085476e59302e Mon Sep 17 00:00:00 2001 From: Charles Cooper Date: Fri, 3 Feb 2017 10:59:22 -0500 Subject: [PATCH 5/9] Compile for windows --- System/Process/Windows.hsc | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc index ff8d3a79..6c92b02d 100644 --- a/System/Process/Windows.hsc +++ b/System/Process/Windows.hsc @@ -66,7 +66,8 @@ mkProcessHandle h job io = do then newMVar (OpenHandle h) else newMVar (OpenExtHandle h job io) _ <- mkWeakMVar m (processHandleFinaliser m) - return (ProcessHandle m False) + l <- newMVar () + return (ProcessHandle m False l) processHandleFinaliser :: MVar ProcessHandle__ -> IO () processHandleFinaliser m = From 3f3566f23539863cf1d6e45261651fa4a46ff5b9 Mon Sep 17 00:00:00 2001 From: Charles Cooper Date: Sat, 4 Feb 2017 15:39:42 -0500 Subject: [PATCH 6/9] Add comments --- System/Process.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/System/Process.hs b/System/Process.hs index b78b8315..50c787e3 100644 --- a/System/Process.hs +++ b/System/Process.hs @@ -590,6 +590,7 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc _) = lockWaitpid $ do ClosedHandle e -> return e OpenHandle h -> do e <- alloca $ \pret -> do + -- don't hold the MVar while we call c_waitForProcess... throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret) modifyProcessHandle ph $ \p_' -> case p_' of @@ -613,7 +614,13 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc _) = lockWaitpid $ do #else return $ ExitFailure (-1) #endif - where lockWaitpid m = withMVar (waitpidLock ph) $ \() -> m + where + -- If more than one thread calls `waitpid` at a time, `waitpid` will + -- return the exit code to one of them and (-1) to the rest of them, + -- causing an exception to be thrown. + -- Cf. https://github.com/haskell/process/issues/46, and + -- https://github.com/haskell/process/pull/58 for further discussion + lockWaitpid m = withMVar (waitpidLock ph) $ \() -> m -- ---------------------------------------------------------------------------- -- getProcessExitCode From fd79da2d7c0f11b4ab70cbd232c2025af43430b5 Mon Sep 17 00:00:00 2001 From: Charles Cooper Date: Sat, 4 Feb 2017 15:43:29 -0500 Subject: [PATCH 7/9] Listen to -Werror --- test/main.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/test/main.hs b/test/main.hs index f89f3ef2..edb561a6 100644 --- a/test/main.hs +++ b/test/main.hs @@ -71,12 +71,14 @@ main = do do -- multithreaded waitForProcess (_, _, _, p) <- createProcess (proc "sleep" ["0.1"]) me1 <- newEmptyMVar - forkIO . void $ waitForProcess p >>= putMVar me1 + _ <- forkIO . void $ waitForProcess p >>= putMVar me1 -- check for race / deadlock between waitForProcess and getProcessExitCode e3 <- getProcessExitCode p e2 <- waitForProcess p e1 <- readMVar me1 - unless (isNothing e3 && e1 == ExitSuccess && e2 == ExitSuccess) + unless (isNothing e3) + $ error $ "unexpected exit " ++ show e3 + unless (e1 == ExitSuccess && e2 == ExitSuccess) $ error "sleep exited with non-zero exit code!" putStrLn "Tests passed successfully" From c722d8b85568d2185dbe716a9988697eccb27e56 Mon Sep 17 00:00:00 2001 From: Charles Cooper Date: Fri, 17 Feb 2017 12:03:01 -0800 Subject: [PATCH 8/9] Check if waitpidLock is held in getProcessExitCode --- System/Process.hs | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/System/Process.hs b/System/Process.hs index 50c787e3..0a5e93ee 100644 --- a/System/Process.hs +++ b/System/Process.hs @@ -77,7 +77,7 @@ import System.Process.Internals import Control.Concurrent import Control.DeepSeq (rnf) -import Control.Exception (SomeException, mask, try, throwIO) +import Control.Exception (SomeException, mask, bracket, try, throwIO) import qualified Control.Exception as C import Control.Monad import Data.Maybe @@ -635,7 +635,7 @@ when the process died as the result of a signal. -} getProcessExitCode :: ProcessHandle -> IO (Maybe ExitCode) -getProcessExitCode ph@(ProcessHandle _ delegating_ctlc _) = do +getProcessExitCode ph@(ProcessHandle _ delegating_ctlc _) = tryLockWaitpid $ do (m_e, was_open) <- modifyProcessHandle ph $ \p_ -> case p_ of ClosedHandle e -> return (p_, (Just e, False)) @@ -663,6 +663,23 @@ getProcessExitCode ph@(ProcessHandle _ delegating_ctlc _) = do getHandle (ClosedHandle _) = Nothing getHandle (OpenExtHandle h _ _) = Just h + -- If somebody is currently holding the waitpid lock, we don't want to + -- accidentally remove the pid from the process table. + -- Try acquiring the waitpid lock. If it is held, we are done + -- since that means the process is still running and we can return + -- `Nothing`. If it is not held, acquire it so we can run the + -- (non-blocking) call to `waitpid` without worrying about any + -- other threads calling it at the same time. + tryLockWaitpid :: IO (Maybe ExitCode) -> IO (Maybe ExitCode) + tryLockWaitpid action = bracket acquire release between + where + acquire = tryTakeMVar (waitpidLock ph) + release m = case m of + Nothing -> return () + Just () -> putMVar (waitpidLock ph) () + between m = case m of + Nothing -> return Nothing + Just () -> do action -- ---------------------------------------------------------------------------- -- terminateProcess From 48c8fde957e76235224b80149b7f54796c9a6e30 Mon Sep 17 00:00:00 2001 From: Charles Cooper Date: Mon, 20 Feb 2017 12:19:36 -0800 Subject: [PATCH 9/9] Remove extra whitespace --- System/Process.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/System/Process.hs b/System/Process.hs index 0a5e93ee..bc4c1ae1 100644 --- a/System/Process.hs +++ b/System/Process.hs @@ -679,7 +679,7 @@ getProcessExitCode ph@(ProcessHandle _ delegating_ctlc _) = tryLockWaitpid $ do Just () -> putMVar (waitpidLock ph) () between m = case m of Nothing -> return Nothing - Just () -> do action + Just () -> action -- ---------------------------------------------------------------------------- -- terminateProcess