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

Supports threadWaitReadSTM and threadWaitWriteSTM on Windows with the threaded runtime system.

libraries/base/Control/Concurrent.hs

@@ -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
 

libraries/base/GHC/Conc.lhs

@@ -62,6 +62,8 @@ module GHC.Conc
         , registerDelay
         , threadWaitRead
         , threadWaitWrite
+        , threadWaitReadSTM
+        , threadWaitWriteSTM
         , closeFdWith
 
         -- * TVars

libraries/base/GHC/Conc/IO.hs

@@ -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