Commit b0d27b90 authored by AndreasVoellmy's avatar AndreasVoellmy Committed by ian@well-typed.com
Browse files

Expose new threadWaitSTM functions in Control.Concurrent (see #7216).

Supports threadWaitReadSTM and threadWaitWriteSTM on Windows with the threaded runtime system.
parent 104aeb7d
......@@ -66,6 +66,8 @@ module Control.Concurrent (
threadDelay,
threadWaitRead,
threadWaitWrite,
threadWaitReadSTM,
threadWaitWriteSTM,
#endif
-- * Communication abstractions
......@@ -116,7 +118,8 @@ import Control.Exception.Base as Exception
#ifdef __GLASGOW_HASKELL__
import GHC.Exception
import GHC.Conc hiding (threadWaitRead, threadWaitWrite)
import GHC.Conc hiding (threadWaitRead, threadWaitWrite,
threadWaitReadSTM, threadWaitWriteSTM)
import qualified GHC.Conc
import GHC.IO ( IO(..), unsafeInterleaveIO, unsafeUnmask )
import GHC.IORef ( newIORef, readIORef, writeIORef )
......@@ -130,6 +133,7 @@ import Control.Monad ( when )
#ifdef mingw32_HOST_OS
import Foreign.C
import System.IO
import Data.Maybe (Maybe(..))
#endif
#endif
......@@ -448,6 +452,50 @@ threadWaitWrite fd
= GHC.Conc.threadWaitWrite fd
#endif
-- | Returns an STM action that can be used to wait for data
-- to read from a file descriptor. The second returned value
-- is an IO action that can be used to deregister interest
-- in the file descriptor.
threadWaitReadSTM :: Fd -> IO (STM (), IO ())
threadWaitReadSTM fd
#ifdef mingw32_HOST_OS
| threaded = do v <- newTVarIO Nothing
mask_ $ forkIO $ do result <- try (waitFd fd 0)
atomically (writeTVar v $ Just result)
let waitAction = do result <- readTVar v
case result of
Nothing -> retry
Just (Right ()) -> return ()
Just (Left e) -> throwSTM e
let killAction = return ()
return (waitAction, killAction)
| otherwise = error "threadWaitReadSTM requires -threaded on Windows"
#else
= GHC.Conc.threadWaitReadSTM fd
#endif
-- | Returns an STM action that can be used to wait until data
-- can be written to a file descriptor. The second returned value
-- is an IO action that can be used to deregister interest
-- in the file descriptor.
threadWaitWriteSTM :: Fd -> IO (STM (), IO ())
threadWaitWriteSTM fd
#ifdef mingw32_HOST_OS
| threaded = do v <- newTVarIO Nothing
mask_ $ forkIO $ do result <- try (waitFd fd 1)
atomically (writeTVar v $ Just result)
let waitAction = do result <- readTVar v
case result of
Nothing -> retry
Just (Right ()) -> return ()
Just (Left e) -> throwSTM e
let killAction = return ()
return (waitAction, killAction)
| otherwise = error "threadWaitWriteSTM requires -threaded on Windows"
#else
= GHC.Conc.threadWaitWriteSTM fd
#endif
#ifdef mingw32_HOST_OS
foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
......
......@@ -62,6 +62,8 @@ module GHC.Conc
, registerDelay
, threadWaitRead
, threadWaitWrite
, threadWaitReadSTM
, threadWaitWriteSTM
, closeFdWith
-- * TVars
......
......@@ -38,6 +38,8 @@ module GHC.Conc.IO
, registerDelay
, threadWaitRead
, threadWaitWrite
, threadWaitReadSTM
, threadWaitWriteSTM
, closeFdWith
#ifdef mingw32_HOST_OS
......@@ -108,6 +110,44 @@ threadWaitWrite fd
case waitWrite# fd# s of { s' -> (# s', () #)
}}
-- | Returns an STM action that can be used to wait for data
-- to read from a file descriptor. The second returned value
-- is an IO action that can be used to deregister interest
-- in the file descriptor.
threadWaitReadSTM :: Fd -> IO (Sync.STM (), IO ())
threadWaitReadSTM fd
#ifndef mingw32_HOST_OS
| threaded = Event.threadWaitReadSTM fd
#endif
| otherwise = do
m <- Sync.newTVarIO False
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 ()
return (waitAction, killAction)
-- | Returns an STM action that can be used to wait until data
-- can be written to a file descriptor. The second returned value
-- is an IO action that can be used to deregister interest
-- in the file descriptor.
threadWaitWriteSTM :: Fd -> IO (Sync.STM (), IO ())
threadWaitWriteSTM fd
#ifndef mingw32_HOST_OS
| threaded = Event.threadWaitWriteSTM fd
#endif
| otherwise = do
m <- Sync.newTVarIO False
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 ()
return (waitAction, killAction)
-- | Close a file descriptor in a concurrency-safe way (GHC only). If
-- you are using 'threadWaitRead' or 'threadWaitWrite' to perform
-- blocking I\/O, you /must/ use this function to close file
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment