Fix job support

System/Process.hs

@@ -54,12 +54,14 @@ module System.Process (
     -- $ctlc-handling
 
     -- * Process completion
+    -- ** Notes about @exec@ on Windows
+    -- $exec-on-windows
     waitForProcess,
     getProcessExitCode,
     terminateProcess,
     interruptProcessGroupOf,
 
-    -- Interprocess communication
+    -- * Interprocess communication
     createPipe,
     createPipeFd,
 
@@ -394,6 +396,32 @@ processFailedException fun cmd args exit_code =
 -- For even more detail on this topic, see
 -- <http://www.cons.org/cracauer/sigint.html "Proper handling of SIGINT/SIGQUIT">.
 
+-- $exec-on-windows
+--
+-- Note that processes which use the POSIX @exec@ system call (e.g. @gcc@)
+-- require special care on Windows. Specifically, the @msvcrt@ C runtime used
+-- frequently on Windows emulates @exec@ in a non-POSIX compliant manner, where
+-- the caller will be terminated (with exit code 0) and execution will continue
+-- in a new process. As a result, on Windows it will appear as though a child
+-- process which has called @exec@ has terminated despite the fact that the
+-- process would still be running on a POSIX-compliant platform.
+--
+-- Since many programs do use @exec@, the @process@ library exposes the
+-- 'use_process_jobs' flag to make it possible to reliably detect when such a
+-- process completes. When this flag is set a 'ProcessHandle' will not be
+-- deemed to be \"finished\" until all processes spawned by it have
+-- terminated (except those spawned by the child with the
+-- @CREATE_BREAKAWAY_FROM_JOB@ @CreateProcess@ flag).
+--
+-- Note, however, that, because of platform limitations, the exit code returned
+-- by @waitForProcess@ and @getProcessExitCode@ cannot not be relied upon when
+-- the child uses @exec@, even when 'use_process_jobs' is used. Specifically,
+-- these functions will return the exit code of the *original child* (which
+-- always exits with code 0, since it called @exec@), not the exit code of the
+-- process which carried on with execution after @exec@. This is different from
+-- the behavior prescribed by POSIX but is the best approximation that can be
+-- realised under the restrictions of the Windows process model.
+
 -- -----------------------------------------------------------------------------
 
 -- | @readProcess@ forks an external process, reads its standard output
@@ -642,30 +670,36 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc _) = lockWaitpid $ do
   case p_ of
     ClosedHandle e -> return e
     OpenHandle h  -> do
-        e <- alloca $ \pret -> do
-          -- don't hold the MVar while we call c_waitForProcess...
-          throwErrnoIfMinus1Retry_ "waitForProcess" (allowInterrupt >> c_waitForProcess h pret)
-          modifyProcessHandle ph $ \p_' ->
-            case p_' of
-              ClosedHandle e  -> return (p_', e)
-              OpenExtHandle{} -> return (p_', ExitFailure (-1))
-              OpenHandle ph'  -> do
-                closePHANDLE ph'
-                code <- peek pret
-                let e = if (code == 0)
-                       then ExitSuccess
-                       else (ExitFailure (fromIntegral code))
-                return (ClosedHandle e, e)
-        when delegating_ctlc $
-          endDelegateControlC e
-        return e
+        -- don't hold the MVar while we call c_waitForProcess...
+        e <- waitForProcess' h
+        e' <- modifyProcessHandle ph $ \p_' ->
+          case p_' of
+            ClosedHandle e' -> return (p_', e')
+            OpenExtHandle{} -> fail "waitForProcess(OpenExtHandle): this cannot happen"
+            OpenHandle ph'  -> do
+              closePHANDLE ph'
+              when delegating_ctlc $
+                endDelegateControlC e
+              return (ClosedHandle e, e)
+        return e'
 #if defined(WINDOWS)
-    OpenExtHandle _ job iocp ->
-        maybe (ExitFailure (-1)) mkExitCode `fmap` waitForJobCompletion job iocp timeout_Infinite
-      where mkExitCode code | code == 0 = ExitSuccess
-                            | otherwise = ExitFailure $ fromIntegral code
+    OpenExtHandle h job -> do
+        -- First wait for completion of the job...
+        waitForJobCompletion job
+        e <- waitForProcess' h
+        e' <- modifyProcessHandle ph $ \p_' ->
+          case p_' of
+            ClosedHandle e' -> return (p_', e')
+            OpenHandle{}    -> fail "waitForProcess(OpenHandle): this cannot happen"
+            OpenExtHandle ph' job' -> do
+              closePHANDLE ph'
+              closePHANDLE job'
+              when delegating_ctlc $
+                endDelegateControlC e
+              return (ClosedHandle e, e)
+        return e'
 #else
-    OpenExtHandle _ _job _iocp ->
+    OpenExtHandle _ _job ->
         return $ ExitFailure (-1)
 #endif
   where
@@ -676,6 +710,17 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc _) = lockWaitpid $ do
     -- https://github.com/haskell/process/pull/58 for further discussion
     lockWaitpid m = withMVar (waitpidLock ph) $ \() -> m
 
+    waitForProcess' :: PHANDLE -> IO ExitCode
+    waitForProcess' h = alloca $ \pret -> do
+      throwErrnoIfMinus1Retry_ "waitForProcess" (allowInterrupt >> c_waitForProcess h pret)
+      mkExitCode <$> peek pret
+
+    mkExitCode :: CInt -> ExitCode
+    mkExitCode code
+      | code == 0 = ExitSuccess
+      | otherwise = ExitFailure (fromIntegral code)
+
+
 -- ----------------------------------------------------------------------------
 -- getProcessExitCode
 
@@ -715,7 +760,7 @@ getProcessExitCode ph@(ProcessHandle _ delegating_ctlc _) = tryLockWaitpid $ do
     where getHandle :: ProcessHandle__ -> Maybe PHANDLE
           getHandle (OpenHandle        h) = Just h
           getHandle (ClosedHandle      _) = Nothing
-          getHandle (OpenExtHandle h _ _) = Just h
+          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.

System/Process/Common.hs

@@ -103,7 +103,7 @@ data CreateProcess = CreateProcess{
                                            --
                                            --   @since 1.4.0.0
   use_process_jobs :: Bool                 -- ^ On Windows systems this flag indicates that we should wait for the entire process tree
-                                           --   to finish before unblocking. On POSIX systems this flag is ignored.
+                                           --   to finish before unblocking. On POSIX systems this flag is ignored. See $exec-on-windows for details.
                                            --
                                            --   Default: @False@
                                            --
@@ -186,8 +186,13 @@ data StdStream
      completion. This requires two handles. A process job handle and
      a events handle to monitor.
 -}
-data ProcessHandle__ = OpenHandle PHANDLE
-                     | OpenExtHandle PHANDLE PHANDLE PHANDLE
+data ProcessHandle__ = OpenHandle { phdlProcessHandle :: PHANDLE }
+                     | OpenExtHandle { phdlProcessHandle :: PHANDLE
+                                     -- ^ the process
+                                     , phdlJobHandle     :: PHANDLE
+                                     -- ^ the job containing the process and
+                                     -- its subprocesses
+                                     }
                      | ClosedHandle ExitCode
 data ProcessHandle
   = ProcessHandle { phandle          :: !(MVar ProcessHandle__)

System/Process/Windows.hsc

@@ -22,7 +22,6 @@ import System.Process.Common
 import Control.Concurrent
 import Control.Exception
 import Data.Bits
-import Data.Maybe
 import Foreign.C
 import Foreign.Marshal
 import Foreign.Ptr
@@ -60,11 +59,11 @@ throwErrnoIfBadPHandle = throwErrnoIfNull
 
 -- On Windows, we have to close this HANDLE when it is no longer required,
 -- hence we add a finalizer to it
-mkProcessHandle :: PHANDLE -> PHANDLE -> PHANDLE -> IO ProcessHandle
-mkProcessHandle h job io = do
-   m <- if job == nullPtr && io == nullPtr
+mkProcessHandle :: PHANDLE -> PHANDLE -> IO ProcessHandle
+mkProcessHandle h job = do
+   m <- if job == nullPtr
            then newMVar (OpenHandle h)
-           else newMVar (OpenExtHandle h job io)
+           else newMVar (OpenExtHandle h job)
    _ <- mkWeakMVar m (processHandleFinaliser m)
    l <- newMVar ()
    return (ProcessHandle m False l)
@@ -74,9 +73,8 @@ processHandleFinaliser m =
    modifyMVar_ m $ \p_ -> do
         case p_ of
           OpenHandle ph           -> closePHANDLE ph
-          OpenExtHandle ph job io -> closePHANDLE ph
+          OpenExtHandle ph job    -> closePHANDLE ph
                                   >> closePHANDLE job
-                                  >> closePHANDLE io
           _ -> return ()
         return (error "closed process handle")
 
@@ -114,7 +112,6 @@ createProcess_Internal fun CreateProcess{ cmdspec = cmdsp,
    alloca $ \ pfdStdOutput          ->
    alloca $ \ pfdStdError           ->
    allocaBytes lenPtr $ \ hJob      ->
-   allocaBytes lenPtr $ \ hIOcpPort ->
    maybeWith withCEnvironment mb_env $ \pEnv ->
    maybeWith withCWString mb_cwd $ \pWorkDir -> do
    withCWString cmdline $ \pcmdline -> do
@@ -145,15 +142,13 @@ createProcess_Internal fun CreateProcess{ cmdspec = cmdsp,
                                 .|.(if mb_new_session then RUN_PROCESS_NEW_SESSION else 0))
                                 use_job
                                 hJob
-                                hIOcpPort
 
      hndStdInput  <- mbPipe mb_stdin  pfdStdInput  WriteMode
      hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode
      hndStdError  <- mbPipe mb_stderr pfdStdError  ReadMode
 
      phJob  <- peek hJob
-     phIOCP <- peek hIOcpPort
-     ph     <- mkProcessHandle proc_handle phJob phIOCP
+     ph     <- mkProcessHandle proc_handle phJob
      return ProcRetHandles { hStdInput  = hndStdInput
                            , hStdOutput = hndStdOutput
                            , hStdError  = hndStdError
@@ -187,44 +182,21 @@ terminateJob :: ProcessHandle -> CUInt -> IO Bool
 terminateJob jh ecode =
     withProcessHandle jh $ \p_ -> do
         case p_ of
-            ClosedHandle        _ -> return False
-            OpenHandle          _ -> return False
-            OpenExtHandle _ job _ -> c_terminateJobObject job ecode
+            ClosedHandle      _ -> return False
+            OpenHandle        _ -> return False
+            OpenExtHandle _ job -> c_terminateJobObject job ecode
 
 timeout_Infinite :: CUInt
 timeout_Infinite = 0xFFFFFFFF
 
-waitForJobCompletion :: PHANDLE
-                     -> PHANDLE
-                     -> CUInt
-                     -> IO (Maybe CInt)
-waitForJobCompletion job io timeout =
-            alloca $ \p_exitCode -> do
-              items <- newMVar $ []
-              setter <- mkSetter (insertItem items)
-              getter <- mkGetter (getItem items)
-              ret <- c_waitForJobCompletion job io timeout p_exitCode setter getter
-              if ret == 0
-                 then Just <$> peek p_exitCode
-                 else return Nothing
-
-insertItem :: MVar [(k, v)] -> k -> v -> IO ()
-insertItem env_ k v = modifyMVar_ env_ (return . ((k, v):))
-
-getItem :: Eq k => MVar [(k, v)] -> k -> IO v
-getItem env_ k = withMVar env_ (\m -> return $ fromJust $ lookup k m)
+waitForJobCompletion :: PHANDLE -- ^ job handle
+                     -> IO ()
+waitForJobCompletion job =
+    throwErrnoIf_ not "waitForJobCompletion" $ c_waitForJobCompletion job
 
 -- ----------------------------------------------------------------------------
 -- Interface to C bits
 
-type SetterDef = CUInt -> Ptr () -> IO ()
-type GetterDef = CUInt -> IO (Ptr ())
-
-foreign import ccall "wrapper"
-  mkSetter :: SetterDef -> IO (FunPtr SetterDef)
-foreign import ccall "wrapper"
-  mkGetter :: GetterDef -> IO (FunPtr GetterDef)
-
 foreign import WINDOWS_CCONV unsafe "TerminateJobObject"
   c_terminateJobObject
         :: PHANDLE
@@ -234,12 +206,7 @@ foreign import WINDOWS_CCONV unsafe "TerminateJobObject"
 foreign import ccall interruptible "waitForJobCompletion" -- NB. safe - can block
   c_waitForJobCompletion
         :: PHANDLE
-        -> PHANDLE
-        -> CUInt
-        -> Ptr CInt
-        -> FunPtr (SetterDef)
-        -> FunPtr (GetterDef)
-        -> IO CInt
+        -> IO Bool
 
 foreign import ccall unsafe "runInteractiveProcess"
   c_runInteractiveProcess
@@ -255,7 +222,6 @@ foreign import ccall unsafe "runInteractiveProcess"
         -> CInt          -- flags
         -> Bool          -- useJobObject
         -> Ptr PHANDLE       -- Handle to Job
-        -> Ptr PHANDLE       -- Handle to I/O Completion Port
         -> IO PHANDLE
 
 commandToProcess
@@ -338,7 +304,7 @@ createPipeInternal = do
     (do readh <- fdToHandle readfd
         writeh <- fdToHandle writefd
         return (readh, writeh)) `onException` (close' readfd >> close' writefd)
-        
+
 createPipeInternalFd :: IO (FD, FD)
 createPipeInternalFd = do
     allocaArray 2 $ \ pfds -> do
@@ -365,9 +331,9 @@ interruptProcessGroupOfInternal ph = do
         case p_ of
             ClosedHandle _ -> return ()
             _ -> do let h = case p_ of
-                              OpenHandle x        -> x
-                              OpenExtHandle x _ _ -> x
-                              _                   -> error "interruptProcessGroupOfInternal"
+                              OpenHandle x      -> x
+                              OpenExtHandle x _ -> x
+                              _                 -> error "interruptProcessGroupOfInternal"
 #if mingw32_HOST_OS
                     pid <- getProcessId h
                     generateConsoleCtrlEvent cTRL_BREAK_EVENT pid