1 {-# LANGUAGE BangPatterns, ForeignFunctionInterface, NoImplicitPrelude #-}
3 module GHC.Event.Thread
4 ( getSystemEventManager
5 , ensureIOManagerIsRunning
13 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
14 import Data.Maybe (Maybe(..))
15 import Foreign.C.Error (eBADF, errnoToIOError)
16 import Foreign.Ptr (Ptr)
18 import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO,
19 labelThread, modifyMVar_, newTVar, sharedCAF,
20 threadStatus, writeTVar)
21 import GHC.IO (mask_, onException)
22 import GHC.IO.Exception (ioError)
23 import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
24 import GHC.Event.Internal (eventIs, evtClose)
25 import GHC.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,
26 new, registerFd, unregisterFd_, registerTimeout)
27 import qualified GHC.Event.Manager as M
28 import System.IO.Unsafe (unsafePerformIO)
29 import System.Posix.Types (Fd)
31 -- | Suspends the current thread for a given number of microseconds
34 -- There is no guarantee that the thread will be rescheduled promptly
35 -- when the delay has expired, but the thread will never continue to
36 -- run /earlier/ than specified.
37 threadDelay :: Int -> IO ()
38 threadDelay usecs = mask_ $ do
39 Just mgr <- getSystemEventManager
41 reg <- registerTimeout mgr usecs (putMVar m ())
42 takeMVar m `onException` M.unregisterTimeout mgr reg
44 -- | Set the value of returned TVar to True after a given number of
45 -- microseconds. The caveats associated with threadDelay also apply.
47 registerDelay :: Int -> IO (TVar Bool)
48 registerDelay usecs = do
49 t <- atomically $ newTVar False
50 Just mgr <- getSystemEventManager
51 _ <- registerTimeout mgr usecs . atomically $ writeTVar t True
54 -- | Block the current thread until data is available to read from the
55 -- given file descriptor.
57 -- This will throw an 'IOError' if the file descriptor was closed
58 -- while this thread was blocked. To safely close a file descriptor
59 -- that has been used with 'threadWaitRead', use 'closeFdWith'.
60 threadWaitRead :: Fd -> IO ()
61 threadWaitRead = threadWait evtRead
62 {-# INLINE threadWaitRead #-}
64 -- | Block the current thread until the given file descriptor can
65 -- accept data to write.
67 -- This will throw an 'IOError' if the file descriptor was closed
68 -- while this thread was blocked. To safely close a file descriptor
69 -- that has been used with 'threadWaitWrite', use 'closeFdWith'.
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 closeFdWith :: (Fd -> IO ()) -- ^ Action that performs the close.
80 -> Fd -- ^ File descriptor to close.
82 closeFdWith close fd = do
83 Just mgr <- getSystemEventManager
84 M.closeFd mgr close fd
86 threadWait :: Event -> Fd -> IO ()
87 threadWait evt fd = mask_ $ do
89 Just mgr <- getSystemEventManager
90 reg <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> putMVar m e) fd evt
91 evt' <- takeMVar m `onException` unregisterFd_ mgr reg
92 if evt' `eventIs` evtClose
93 then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing
96 -- | Retrieve the system event manager.
98 -- This function always returns 'Just' the system event manager when using the
99 -- threaded RTS and 'Nothing' otherwise.
100 getSystemEventManager :: IO (Maybe EventManager)
101 getSystemEventManager = readIORef eventManager
103 foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore"
104 getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a)
106 eventManager :: IORef (Maybe EventManager)
107 eventManager = unsafePerformIO $ do
108 em <- newIORef Nothing
109 sharedCAF em getOrSetSystemEventThreadEventManagerStore
110 {-# NOINLINE eventManager #-}
112 foreign import ccall unsafe "getOrSetSystemEventThreadIOManagerThreadStore"
113 getOrSetSystemEventThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a)
115 {-# NOINLINE ioManager #-}
116 ioManager :: MVar (Maybe ThreadId)
117 ioManager = unsafePerformIO $ do
119 sharedCAF m getOrSetSystemEventThreadIOManagerThreadStore
121 ensureIOManagerIsRunning :: IO ()
122 ensureIOManagerIsRunning
123 | not threaded = return ()
124 | otherwise = modifyMVar_ ioManager $ \old -> do
127 writeIORef eventManager $ Just mgr
128 !t <- forkIO $ loop mgr
129 labelThread t "IOManager"
136 ThreadFinished -> create
138 -- Sanity check: if the thread has died, there is a chance
139 -- that event manager is still alive. This could happend during
140 -- the fork, for example. In this case we should clean up
141 -- open pipes and everything else related to the event manager.
143 mem <- readIORef eventManager
146 Just em -> M.cleanup em
150 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool