[commit: base] master: Added threadWait functions to wait on FD readiness with STM actions. (02a58a4)

[Ian Lynagh]

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

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/02a58a422c230d0c4162011133c47b307c9fc414

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

commit 02a58a422c230d0c4162011133c47b307c9fc414
Author: Andreas Voellmy <andreas.voellmy at gmail.com>
Date:   Tue Aug 28 23:44:30 2012 -0400

    Added threadWait functions to wait on FD readiness with STM actions.

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

 GHC/Event/Thread.hs |   28 +++++++++++++++++++++++++++-
 1 files changed, 27 insertions(+), 1 deletions(-)

diff --git a/GHC/Event/Thread.hs b/GHC/Event/Thread.hs
index 237cb45..7df531f 100644
--- a/GHC/Event/Thread.hs
+++ b/GHC/Event/Thread.hs
@@ -6,6 +6,8 @@ module GHC.Event.Thread
     , ensureIOManagerIsRunning
     , threadWaitRead
     , threadWaitWrite
+    , threadWaitReadSTM
+    , threadWaitWriteSTM
     , closeFdWith
     , threadDelay
     , registerDelay
@@ -18,7 +20,7 @@ import Foreign.Ptr (Ptr)
 import GHC.Base
 import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO,
                       labelThread, modifyMVar_, newTVar, sharedCAF,
-                      threadStatus, writeTVar)
+                      threadStatus, writeTVar, newTVarIO, readTVar, retry,throwSTM,STM)
 import GHC.IO (mask_, onException)
 import GHC.IO.Exception (ioError)
 import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
@@ -95,6 +97,30 @@ threadWait evt fd = mask_ $ do
     then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing
     else return ()
 
+
+threadWaitSTM :: Event -> Fd -> IO (STM ())
+threadWaitSTM evt fd = mask_ $ do
+  m <- newTVarIO Nothing
+  Just mgr <- getSystemEventManager 
+  registerFd mgr (\reg e -> unregisterFd_ mgr reg >> atomically (writeTVar m (Just e))) fd evt
+  return (do mevt <- readTVar m
+             case mevt of
+               Nothing -> retry
+               Just evt -> 
+                 if evt `eventIs` evtClose
+                 then throwSTM $ errnoToIOError "threadWait" eBADF Nothing Nothing
+                 else return ()
+         )
+
+threadWaitReadSTM :: Fd -> IO (STM ())
+threadWaitReadSTM = threadWaitSTM evtRead
+{-# INLINE threadWaitReadSTM #-}
+
+threadWaitWriteSTM :: Fd -> IO (STM ())
+threadWaitWriteSTM = threadWaitSTM evtWrite
+{-# INLINE threadWaitWriteSTM #-}
+
+
 -- | Retrieve the system event manager.
 --
 -- This function always returns 'Just' the system event manager when using the