[commit: base] master: Expose new threadWaitSTM functions in Control.Concurrent (see #7216). (228f0ed)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/base

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/228f0edeb3b68e29b675c136b7fb8a577646d36a

>---------------------------------------------------------------

commit 228f0edeb3b68e29b675c136b7fb8a577646d36a
Author: Andreas Voellmy <andreas.voellmy at gmail.com>
Date:   Sun Dec 30 22:11:56 2012 +0100

    Expose new threadWaitSTM functions in Control.Concurrent (see #7216).
    
    Supports threadWaitReadSTM and threadWaitWriteSTM on Windows with the threaded runtime system.

>---------------------------------------------------------------

 Control/Concurrent.hs |   50 ++++++++++++++++++++++++++++++++++++++++++++++++-
 GHC/Conc.lhs          |    2 +
 GHC/Conc/IO.hs        |   40 +++++++++++++++++++++++++++++++++++++++
 3 files changed, 91 insertions(+), 1 deletions(-)

diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs
index 100ccc5..3733a07 100644
--- a/Control/Concurrent.hs
+++ b/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
 
diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 914db3f..f5fb275 100644
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -62,6 +62,8 @@ module GHC.Conc
         , registerDelay
         , threadWaitRead
         , threadWaitWrite
+        , threadWaitReadSTM
+        , threadWaitWriteSTM
         , closeFdWith
 
         -- * TVars
diff --git a/GHC/Conc/IO.hs b/GHC/Conc/IO.hs
index 94a63a9..a99b334 100644
--- a/GHC/Conc/IO.hs
+++ b/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