Allow async exceptions to pierce masked waitForProcess
authorMitchell Rosen <mitchellwrosen@gmail.com>
Thu, 3 Aug 2017 15:11:02 +0000 (11:11 -0400)
committerMitchell Rosen <mitchellwrosen@gmail.com>
Thu, 3 Aug 2017 15:11:02 +0000 (11:11 -0400)
System/Process.hs
test/main.hs

index 7c1a342..c0f458a 100644 (file)
@@ -77,7 +77,7 @@ import System.Process.Internals
 
 import Control.Concurrent
 import Control.DeepSeq (rnf)
-import Control.Exception (SomeException, mask, bracket, try, throwIO)
+import Control.Exception (SomeException, mask, allowInterrupt, bracket, try, throwIO)
 import qualified Control.Exception as C
 import Control.Monad
 import Data.Maybe
@@ -589,7 +589,7 @@ waitForProcess ph@(ProcessHandle _ delegating_ctlc _) = lockWaitpid $ do
     OpenHandle h  -> do
         e <- alloca $ \pret -> do
           -- don't hold the MVar while we call c_waitForProcess...
-          throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret)
+          throwErrnoIfMinus1Retry_ "waitForProcess" (allowInterrupt >> c_waitForProcess h pret)
           modifyProcessHandle ph $ \p_' ->
             case p_' of
               ClosedHandle e  -> return (p_', e)
index edb561a..b3d6f4a 100644 (file)
@@ -81,6 +81,17 @@ main = do
       unless (e1 == ExitSuccess && e2 == ExitSuccess)
             $ error "sleep exited with non-zero exit code!"
 
+    do
+      putStrLn "interrupt masked waitForProcess"
+      (_, _, _, p) <- createProcess (proc "sleep" ["0.1"])
+      mec <- newEmptyMVar
+      tid <- mask_ . forkIO $ waitForProcess p >>= putMVar mec
+      killThread tid
+      eec <- try (takeMVar mec)
+      case eec of
+        Left BlockedIndefinitelyOnMVar -> return ()
+        Right ec -> error "waitForProcess not interrupted"
+
     putStrLn "Tests passed successfully"
 
 withCurrentDirectory :: FilePath -> IO a -> IO a