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 <[email protected]> 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 _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
