From ee88c20da4e8dcd1ccc19e5af4663b672ced1081 Mon Sep 17 00:00:00 2001 From: simonmar Date: Thu, 17 Nov 2005 11:28:44 +0000 Subject: [PATCH] [project @ 2005-11-17 11:28:43 by simonmar] ProcessHandle is now an MVar, in which we cache the ExitCode of the process when we know it. Additionally, waitForProcess and getProcessExitCode now close the handle eagerly on Windows, this avoids a problem with hsc2hs which wants to remove the executable it just ran, and it can't if the handle is still open. --- System/Process.hs | 56 ++++++++++++++++++++++++++++++------------- System/Process/Internals.hs | 52 ++++++++++++++++++++++++++++++---------- 2 files changed, 79 insertions(+), 29 deletions(-) diff --git a/System/Process.hs b/System/Process.hs index d4bc43f..91a9359 100644 --- a/System/Process.hs +++ b/System/Process.hs @@ -237,11 +237,23 @@ waitForProcess :: ProcessHandle -> IO ExitCode waitForProcess ph = do - handle <- getProcessHandle ph - code <- throwErrnoIfMinus1 "waitForProcess" (c_waitForProcess handle) - if (code == 0) - then return ExitSuccess - else return (ExitFailure (fromIntegral code)) + p_ <- withProcessHandle 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) + code <- throwErrnoIfMinus1 "waitForProcess" (c_waitForProcess h) + withProcessHandle ph $ \p_ -> + case p_ of + ClosedHandle e -> return (p_,e) + OpenHandle ph -> do + closePHANDLE ph + let e = if (code == 0) + then ExitSuccess + else (ExitFailure (fromIntegral code)) + return (ClosedHandle e, e) -- ---------------------------------------------------------------------------- -- terminateProcess @@ -256,8 +268,14 @@ waitForProcess ph = do -- an exit code of 1. terminateProcess :: ProcessHandle -> IO () terminateProcess ph = do - pid <- getProcessHandle ph - throwErrnoIfMinus1_ "terminateProcess" (c_terminateProcess pid) + withProcessHandle_ ph $ \p_ -> + case p_ of + ClosedHandle _ -> return p_ + OpenHandle h -> do + throwErrnoIfMinus1_ "terminateProcess" $ c_terminateProcess h + return p_ + -- does not close the handle, we might want to try terminating it + -- again, or get its exit code. -- ---------------------------------------------------------------------------- -- getProcessExitCode @@ -271,15 +289,21 @@ Subsequent calls to @getProcessExitStatus@ always return @'Just' -} getProcessExitCode :: ProcessHandle -> IO (Maybe ExitCode) getProcessExitCode ph = do - handle <- getProcessHandle ph - alloca $ \pExitCode -> do - res <- throwErrnoIfMinus1 "getProcessExitCode" (c_getProcessExitCode handle pExitCode) - code <- peek pExitCode - if res == 0 - then return Nothing - else if code == 0 - then return (Just ExitSuccess) - else return (Just (ExitFailure (fromIntegral code))) + withProcessHandle ph $ \p_ -> + case p_ of + ClosedHandle e -> return (p_, Just e) + OpenHandle h -> + alloca $ \pExitCode -> do + res <- throwErrnoIfMinus1 "getProcessExitCode" $ + c_getProcessExitCode h pExitCode + code <- peek pExitCode + if res == 0 + then return (p_, Nothing) + else do + closePHANDLE h + let e | code == 0 = ExitSuccess + | otherwise = ExitFailure (fromIntegral code) + return (ClosedHandle e, Just e) -- ---------------------------------------------------------------------------- -- Interface to C bits diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs index 36b0f24..b0af3de 100644 --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -15,7 +15,9 @@ -- #hide module System.Process.Internals ( - ProcessHandle(..), PHANDLE, getProcessHandle, mkProcessHandle, + ProcessHandle(..), ProcessHandle__(..), + PHANDLE, closePHANDLE, mkProcessHandle, + withProcessHandle, withProcessHandle_, #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) pPrPr_disableITimers, c_execvpe, # ifdef __GLASGOW_HASKELL__ @@ -43,6 +45,7 @@ import Data.Word ( Word32 ) import Data.IORef #endif +import System.Exit ( ExitCode ) import Data.Maybe ( fromMaybe ) # ifdef __GLASGOW_HASKELL__ import GHC.IOBase ( haFD, FD, Exception(..), IOException(..) ) @@ -51,6 +54,7 @@ import GHC.Handle ( stdin, stdout, stderr, withHandle_ ) import Hugs.Exception ( Exception(..), IOException(..) ) # endif +import Control.Concurrent import Control.Exception ( handle, throwIO ) import Foreign.C import Foreign @@ -81,33 +85,55 @@ import System.Directory.Internals ( parseSearchPath, joinFileName ) termination: they all return a 'ProcessHandle' which may be used to wait for the process later. -} +data ProcessHandle__ = OpenHandle PHANDLE | ClosedHandle ExitCode +newtype ProcessHandle = ProcessHandle (MVar ProcessHandle__) + +withProcessHandle + :: ProcessHandle + -> (ProcessHandle__ -> IO (ProcessHandle__, a)) + -> IO a +withProcessHandle (ProcessHandle m) io = modifyMVar m io + +withProcessHandle_ + :: ProcessHandle + -> (ProcessHandle__ -> IO ProcessHandle__) + -> IO () +withProcessHandle_ (ProcessHandle m) io = modifyMVar_ m io + #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) type PHANDLE = CPid -newtype ProcessHandle = ProcessHandle PHANDLE - -getProcessHandle :: ProcessHandle -> IO PHANDLE -getProcessHandle (ProcessHandle p) = return p mkProcessHandle :: PHANDLE -> IO ProcessHandle -mkProcessHandle p = return (ProcessHandle p) +mkProcessHandle p = do + m <- newMVar (OpenHandle p) + return (ProcessHandle m) + +closePHANDLE :: PHANDLE -> IO () +closePHANDLE _ = return () #else type PHANDLE = Word32 -newtype ProcessHandle = ProcessHandle (IORef PHANDLE) - -getProcessHandle :: ProcessHandle -> IO PHANDLE -getProcessHandle (ProcessHandle ior) = readIORef ior -- On Windows, we have to close this HANDLE when it is no longer required, -- hence we add a finalizer to it, using an IORef as the box on which to -- attach the finalizer. mkProcessHandle :: PHANDLE -> IO ProcessHandle mkProcessHandle h = do - ioref <- newIORef h - mkWeakIORef ioref (c_CloseHandle h) - return (ProcessHandle ioref) + m <- newMVar (OpenHandle h) + addMVarFinalizer m (processHandleFinaliser m) + return (ProcessHandle m) + +processHandleFinaliser m = + modifyMVar_ m $ \p_ -> do + case p_ of + OpenHandle ph -> closePHANDLE ph + _ -> return () + return (error "closed process handle") + +closePHANDLE :: PHANDLE -> IO () +closePHANDLE ph = c_CloseHandle ph foreign import stdcall unsafe "CloseHandle" c_CloseHandle -- 1.7.10.4