diff --git a/System/Process.hs b/System/Process.hs index aae85cf28d1823abfb28aa639378c0befe3f8956..7a16378a5421302d7ea8d3ec0c1f159d9cc210bb 100644 --- a/System/Process.hs +++ b/System/Process.hs @@ -817,7 +817,7 @@ terminateProcess ph = do case p_ of ClosedHandle _ -> return () #if defined(WINDOWS) - OpenExtHandle{} -> terminateJob ph 1 >> return () + OpenExtHandle{} -> terminateJobUnsafe p_ 1 >> return () #else OpenExtHandle{} -> error "terminateProcess with OpenExtHandle should not happen on POSIX." #endif diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs index 8d8e00b1a226b006b5b8973eca99c7a465c96f1f..fb7f38b33819c76d4f602b7606954a503e2deddc 100644 --- a/System/Process/Internals.hs +++ b/System/Process/Internals.hs @@ -41,6 +41,7 @@ module System.Process.Internals ( unwrapHandles, #ifdef WINDOWS terminateJob, + terminateJobUnsafe, waitForJobCompletion, timeout_Infinite, #else diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc index 757940a7076081df63c13eeca72891ddb23454b2..6c91326eea8a82bbfe2004f1a13f1874af721fe8 100644 --- a/System/Process/Windows.hsc +++ b/System/Process/Windows.hsc @@ -14,6 +14,7 @@ module System.Process.Windows , createPipeInternalFd , interruptProcessGroupOfInternal , terminateJob + , terminateJobUnsafe , waitForJobCompletion , timeout_Infinite ) where @@ -278,14 +279,18 @@ stopDelegateControlC = return () -- ---------------------------------------------------------------------------- -- Interface to C I/O CP bits -terminateJob :: ProcessHandle -> CUInt -> IO Bool -terminateJob jh ecode = - withProcessHandle jh $ \p_ -> do +-- | Variant of terminateJob that is not thread-safe +terminateJobUnsafe :: ProcessHandle__ -> CUInt -> IO Bool +terminateJobUnsafe p_ ecode = do case p_ of ClosedHandle _ -> return False OpenHandle _ -> return False OpenExtHandle _ job -> c_terminateJobObject job ecode +terminateJob :: ProcessHandle -> CUInt -> IO Bool +terminateJob jh ecode = + withProcessHandle jh $ \p_ -> terminateJobUnsafe p_ ecode + timeout_Infinite :: CUInt timeout_Infinite = 0xFFFFFFFF diff --git a/changelog.md b/changelog.md index 793e25b80a241506452a45d7a4c348695ff4547d..672f5c0e3fec1fbe5a809b783dbbe06e08b5fe0a 100644 --- a/changelog.md +++ b/changelog.md @@ -4,6 +4,7 @@ * Windows: Add support for new I/O manager in GHC 8.12[#177](https://github.com/haskell/process/pull/177) * Deprecate use of `createPipeFd` in favor of `createPipe` +* Fix MVar re-entrant problem on Windows with `terminateProcess` and process jobs. See [#199](https://github.com/haskell/process/pull/199) ## 1.6.10.0 *June 2020* diff --git a/process.cabal b/process.cabal index 66bef6b79d743ef4df965a3086eacac0013df80d..1e360014325529ccb79a06f9a36f42bc2f1a0caf 100644 --- a/process.cabal +++ b/process.cabal @@ -95,3 +95,5 @@ test-suite test , process ghc-options: -threaded -with-rtsopts "-N" + if os(windows) + cpp-options: -DWINDOWS diff --git a/test/main.hs b/test/main.hs index 18fb3f61e29588dd3e3f95501732abf302856081..b7c5627dffc883457df2017684c584f06de28b4c 100644 --- a/test/main.hs +++ b/test/main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} import Control.Exception import Control.Monad (guard, unless, void) import System.Exit @@ -97,7 +98,11 @@ main = do putStrLn "testing getPid" do +#ifdef WINDOWS + (_, Just out, _, p) <- createProcess $ (proc "sh" ["-c", "z=$$; cat /proc/$z/winpid"]) {std_out = CreatePipe} +#else (_, Just out, _, p) <- createProcess $ (proc "sh" ["-c", "echo $$"]) {std_out = CreatePipe} +#endif pid <- getPid p line <- hGetContents out putStrLn $ " queried PID: " ++ show pid