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 is blocked.
61 threadWaitRead :: Fd -> IO ()
62 threadWaitRead = threadWait evtRead
63 {-# INLINE threadWaitRead #-}
65 -- | Block the current thread until the given file descriptor can
66 -- accept data to write.
68 -- This will throw an 'IOError' if the file descriptor was closed
69 -- while this thread is blocked.
70 threadWaitWrite :: Fd -> IO ()
71 threadWaitWrite = threadWait evtWrite
72 {-# INLINE threadWaitWrite #-}
74 -- | Close a file descriptor in a concurrency-safe way.
76 -- Any threads that are blocked on the file descriptor via
77 -- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having
78 -- IO exceptions thrown.
79 closeFd :: (Fd -> IO ()) -- ^ Action that performs the close.
80 -> Fd -- ^ File descriptor to close.
83 Just mgr <- readIORef eventManager
84 M.closeFd mgr close fd
86 threadWait :: Event -> Fd -> IO ()
87 threadWait evt fd = do
89 Just mgr <- readIORef eventManager
90 reg <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> putMVar m e) fd evt
91 evt' <- takeMVar m `catch` \(e::SomeException) ->
92 unregisterFd_ mgr reg >> throw e
93 if evt' `eventIs` evtClose
94 then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing
97 foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore"
98 getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a)
100 eventManager :: IORef (Maybe EventManager)
101 eventManager = unsafePerformIO $ do
102 em <- newIORef Nothing
103 sharedCAF em getOrSetSystemEventThreadEventManagerStore
104 {-# NOINLINE eventManager #-}
106 foreign import ccall unsafe "getOrSetSystemEventThreadIOManagerThreadStore"
107 getOrSetSystemEventThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a)
109 {-# NOINLINE ioManager #-}
110 ioManager :: MVar (Maybe ThreadId)
111 ioManager = unsafePerformIO $ do
113 sharedCAF m getOrSetSystemEventThreadIOManagerThreadStore
115 ensureIOManagerIsRunning :: IO ()
116 ensureIOManagerIsRunning
117 | not threaded = return ()
118 | otherwise = modifyMVar_ ioManager $ \old -> do
121 writeIORef eventManager $ Just mgr
122 !t <- forkIO $ loop mgr
123 labelThread t "IOManager"
130 ThreadFinished -> create
134 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool