1 {-# LANGUAGE BangPatterns, ForeignFunctionInterface, NoImplicitPrelude #-}
3 module System.Event.Thread
5 ensureIOManagerIsRunning
13 import Control.Exception (SomeException, catch, throw)
14 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
15 import Data.Maybe (Maybe(..))
16 import Foreign.C.Error (eBADF, errnoToIOError)
17 import Foreign.Ptr (Ptr)
19 import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO,
20 labelThread, modifyMVar_, newTVar, sharedCAF,
21 threadStatus, writeTVar)
22 import GHC.IO.Exception (ioError)
23 import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
24 import GHC.Real (fromIntegral)
25 import System.Event.Internal (eventIs, evtClose)
26 import System.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,
27 new, registerFd, unregisterFd_, registerTimeout)
28 import qualified System.Event.Manager as M
29 import System.IO.Unsafe (unsafePerformIO)
30 import System.Posix.Types (Fd)
32 -- | Suspends the current thread for a given number of microseconds
35 -- There is no guarantee that the thread will be rescheduled promptly
36 -- when the delay has expired, but the thread will never continue to
37 -- run /earlier/ than specified.
38 threadDelay :: Int -> IO ()
39 threadDelay usecs = do
40 Just mgr <- readIORef eventManager
42 reg <- registerTimeout mgr usecs (putMVar m ())
43 takeMVar m `catch` \(e::SomeException) ->
44 M.unregisterTimeout mgr reg >> throw e
46 -- | Set the value of returned TVar to True after a given number of
47 -- microseconds. The caveats associated with threadDelay also apply.
49 registerDelay :: Int -> IO (TVar Bool)
50 registerDelay usecs = do
51 t <- atomically $ newTVar False
52 Just mgr <- readIORef eventManager
53 _ <- registerTimeout mgr usecs . atomically $ writeTVar t True
56 -- | Block the current thread until data is available to read from the
57 -- given file descriptor.
59 -- This will throw an 'IOError' if the file descriptor was closed
60 -- while this thread was blocked. To safely close a file descriptor
61 -- that has been used with 'threadWaitRead', use 'closeFdWith'.
62 threadWaitRead :: Fd -> IO ()
63 threadWaitRead = threadWait evtRead
64 {-# INLINE threadWaitRead #-}
66 -- | Block the current thread until the given file descriptor can
67 -- accept data to write.
69 -- This will throw an 'IOError' if the file descriptor was closed
70 -- while this thread was blocked. To safely close a file descriptor
71 -- that has been used with 'threadWaitWrite', use 'closeFdWith'.
72 threadWaitWrite :: Fd -> IO ()
73 threadWaitWrite = threadWait evtWrite
74 {-# INLINE threadWaitWrite #-}
76 -- | Close a file descriptor in a concurrency-safe way.
78 -- Any threads that are blocked on the file descriptor via
79 -- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having
80 -- IO exceptions thrown.
81 closeFdWith :: (Fd -> IO ()) -- ^ Action that performs the close.
82 -> Fd -- ^ File descriptor to close.
84 closeFdWith close fd = do
85 Just mgr <- readIORef eventManager
86 M.closeFd mgr close fd
88 threadWait :: Event -> Fd -> IO ()
89 threadWait evt fd = do
91 Just mgr <- readIORef eventManager
92 reg <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> putMVar m e) fd evt
93 evt' <- takeMVar m `catch` \(e::SomeException) ->
94 unregisterFd_ mgr reg >> throw e
95 if evt' `eventIs` evtClose
96 then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing
99 foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore"
100 getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a)
102 eventManager :: IORef (Maybe EventManager)
103 eventManager = unsafePerformIO $ do
104 em <- newIORef Nothing
105 sharedCAF em getOrSetSystemEventThreadEventManagerStore
106 {-# NOINLINE eventManager #-}
108 foreign import ccall unsafe "getOrSetSystemEventThreadIOManagerThreadStore"
109 getOrSetSystemEventThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a)
111 {-# NOINLINE ioManager #-}
112 ioManager :: MVar (Maybe ThreadId)
113 ioManager = unsafePerformIO $ do
115 sharedCAF m getOrSetSystemEventThreadIOManagerThreadStore
117 ensureIOManagerIsRunning :: IO ()
118 ensureIOManagerIsRunning
119 | not threaded = return ()
120 | otherwise = modifyMVar_ ioManager $ \old -> do
123 writeIORef eventManager $ Just mgr
124 !t <- forkIO $ loop mgr
125 labelThread t "IOManager"
132 ThreadFinished -> create
136 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool