From dedd802749c8002ff24504727d81d2c0f7f5ab52 Mon Sep 17 00:00:00 2001
From: Andreas Voellmy <andreas.voellmy@gmail.com>
Date: Tue, 28 Aug 2012 23:44:30 -0400
Subject: [PATCH] Added threadWait functions to wait on FD readiness with STM
actions.
---
GHC/Event/Thread.hs | 28 +++++++++++++++++++++++++++-
1 file changed, 27 insertions(+), 1 deletion(-)
diff --git a/GHC/Event/Thread.hs b/GHC/Event/Thread.hs
index 2643950..794f01e 100644
|
a
|
b
|
|
| 6 | 6 | , ensureIOManagerIsRunning |
| 7 | 7 | , threadWaitRead |
| 8 | 8 | , threadWaitWrite |
| | 9 | , threadWaitReadSTM |
| | 10 | , threadWaitWriteSTM |
| 9 | 11 | , closeFdWith |
| 10 | 12 | , threadDelay |
| 11 | 13 | , registerDelay |
| … |
… |
|
| 18 | 20 | import GHC.Base |
| 19 | 21 | import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO, |
| 20 | 22 | labelThread, modifyMVar_, newTVar, sharedCAF, |
| 21 | | threadStatus, writeTVar |
| | 23 | threadStatus, writeTVar, newTVarIO, readTVar, retry,throwSTM,STM) |
| 22 | 24 | import GHC.IO (mask_, onException) |
| 23 | 25 | import GHC.IO.Exception (ioError) |
| 24 | 26 | import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar) |
| … |
… |
|
| 94 | 96 | then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing |
| 95 | 97 | else return () |
| 96 | 98 | |
| | 99 | |
| | 100 | threadWaitSTM :: Event -> Fd -> IO (STM ()) |
| | 101 | threadWaitSTM evt fd = mask_ $ do |
| | 102 | m <- newTVarIO Nothing |
| | 103 | Just mgr <- getSystemEventManager |
| | 104 | registerFd mgr (\reg e -> unregisterFd_ mgr reg >> atomically (writeTVar m (Just e))) fd evt |
| | 105 | return (do mevt <- readTVar m |
| | 106 | case mevt of |
| | 107 | Nothing -> retry |
| | 108 | Just evt -> |
| | 109 | if evt `eventIs` evtClose |
| | 110 | then throwSTM $ errnoToIOError "threadWait" eBADF Nothing Nothing |
| | 111 | else return () |
| | 112 | ) |
| | 113 | |
| | 114 | threadWaitReadSTM :: Fd -> IO (STM ()) |
| | 115 | threadWaitReadSTM = threadWaitSTM evtRead |
| | 116 | {-# INLINE threadWaitReadSTM #-} |
| | 117 | |
| | 118 | threadWaitWriteSTM :: Fd -> IO (STM ()) |
| | 119 | threadWaitWriteSTM = threadWaitSTM evtWrite |
| | 120 | {-# INLINE threadWaitWriteSTM #-} |
| | 121 | |
| | 122 | |
| 97 | 123 | -- | Retrieve the system event manager. |
| 98 | 124 | -- |
| 99 | 125 | -- This function always returns 'Just' the system event manager when using the |
