diff options
Diffstat (limited to 'libraries/base')
-rw-r--r-- | libraries/base/GHC/Conc/IO.hs | 12 | ||||
-rw-r--r-- | libraries/base/tests/T12852.hs | 20 | ||||
-rw-r--r-- | libraries/base/tests/T12852.stdout | 3 | ||||
-rw-r--r-- | libraries/base/tests/all.T | 1 |
4 files changed, 30 insertions, 6 deletions
diff --git a/libraries/base/GHC/Conc/IO.hs b/libraries/base/GHC/Conc/IO.hs index 1e9ffd58f0..be773132ee 100644 --- a/libraries/base/GHC/Conc/IO.hs +++ b/libraries/base/GHC/Conc/IO.hs @@ -119,18 +119,18 @@ threadWaitWrite fd -- is an IO action that can be used to deregister interest -- in the file descriptor. threadWaitReadSTM :: Fd -> IO (Sync.STM (), IO ()) -threadWaitReadSTM fd +threadWaitReadSTM fd #ifndef mingw32_HOST_OS | threaded = Event.threadWaitReadSTM fd #endif | otherwise = do m <- Sync.newTVarIO False - _ <- Sync.forkIO $ do + t <- Sync.forkIO $ do threadWaitRead fd Sync.atomically $ Sync.writeTVar m True let waitAction = do b <- Sync.readTVar m if b then return () else retry - let killAction = return () + let killAction = Sync.killThread t return (waitAction, killAction) -- | Returns an STM action that can be used to wait until data @@ -138,18 +138,18 @@ threadWaitReadSTM fd -- is an IO action that can be used to deregister interest -- in the file descriptor. threadWaitWriteSTM :: Fd -> IO (Sync.STM (), IO ()) -threadWaitWriteSTM fd +threadWaitWriteSTM fd #ifndef mingw32_HOST_OS | threaded = Event.threadWaitWriteSTM fd #endif | otherwise = do m <- Sync.newTVarIO False - _ <- Sync.forkIO $ do + t <- Sync.forkIO $ do threadWaitWrite fd Sync.atomically $ Sync.writeTVar m True let waitAction = do b <- Sync.readTVar m if b then return () else retry - let killAction = return () + let killAction = Sync.killThread t return (waitAction, killAction) -- | Close a file descriptor in a concurrency-safe way (GHC only). If diff --git a/libraries/base/tests/T12852.hs b/libraries/base/tests/T12852.hs new file mode 100644 index 0000000000..5bf80d5218 --- /dev/null +++ b/libraries/base/tests/T12852.hs @@ -0,0 +1,20 @@ +import GHC.Conc +import GHC.IO +import GHC.IO.FD as FD +import System.Posix.IO +import System.Posix.Types + +main = do + (rfd,wfd) <- createPipe + (waitread, unregister) <- threadWaitReadSTM rfd + unregister + result0 <- atomically $ (fmap (const False) waitread) `orElse` return True + print result0 + fdWrite wfd "test" + threadDelay 20000 + result1 <- atomically $ (fmap (const False) waitread) `orElse` return True + print result1 + (waitread1, _) <- threadWaitReadSTM rfd + threadDelay 20000 + result2 <- atomically $ (fmap (const True) waitread1) `orElse` return False + print result2 diff --git a/libraries/base/tests/T12852.stdout b/libraries/base/tests/T12852.stdout new file mode 100644 index 0000000000..b8ca7e7ef0 --- /dev/null +++ b/libraries/base/tests/T12852.stdout @@ -0,0 +1,3 @@ +True +True +True diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T index 64ecc88ce8..a9aee1ed76 100644 --- a/libraries/base/tests/all.T +++ b/libraries/base/tests/all.T @@ -205,3 +205,4 @@ test('T9848', test('T10149', normal, compile_and_run, ['']) test('T11334a', normal, compile_and_run, ['']) test('T11555', normal, compile_and_run, ['']) +test('T12852', when(opsys('mingw32'), skip), compile_and_run, ['']) |