Merge pull request #58 from charles-cooper/master

Fix #46

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
@@ -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,15 +584,13 @@ 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
+          -- don't hold the MVar while we call c_waitForProcess...
           throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret)
           modifyProcessHandle ph $ \p_' ->
             case p_' of
@@ -617,6 +615,13 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc) = do
     OpenExtHandle _ _job _iocp ->
         return $ ExitFailure (-1)
 #endif
+  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
@@ -631,7 +636,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))
@@ -659,6 +664,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 () -> action
 
 -- ----------------------------------------------------------------------------
 -- terminateProcess

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

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 ()

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 =

process.cabal

@@ -82,3 +82,5 @@ test-suite test
                , bytestring
                , directory
                , process
+  ghc-options: -threaded
+               -with-rtsopts "-N"

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,19 @@ 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)
+            $ error $ "unexpected exit " ++ show e3
+      unless (e1 == ExitSuccess && e2 == ExitSuccess)
+            $ error "sleep exited with non-zero exit code!"
+
     putStrLn "Tests passed successfully"
 
 withCurrentDirectory :: FilePath -> IO a -> IO a