1 {-# LANGUAGE BangPatterns, ForeignFunctionInterface, NoImplicitPrelude #-}
3 module System.Event.Thread
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 System.Event.Internal (eventIs, evtClose)
25 import System.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,
26 new, registerFd, unregisterFd_, registerTimeout)
27 import qualified System.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 <- readIORef eventManager
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 <- readIORef eventManager
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 <- readIORef eventManager
84 M.closeFd mgr close fd
86 threadWait :: Event -> Fd -> IO ()
87 threadWait evt fd = mask_ $ do
89 Just mgr <- readIORef eventManager
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 foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore"
97 getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a)
99 eventManager :: IORef (Maybe EventManager)
100 eventManager = unsafePerformIO $ do
101 em <- newIORef Nothing
102 sharedCAF em getOrSetSystemEventThreadEventManagerStore
103 {-# NOINLINE eventManager #-}
105 foreign import ccall unsafe "getOrSetSystemEventThreadIOManagerThreadStore"
106 getOrSetSystemEventThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a)
108 {-# NOINLINE ioManager #-}
109 ioManager :: MVar (Maybe ThreadId)
110 ioManager = unsafePerformIO $ do
112 sharedCAF m getOrSetSystemEventThreadIOManagerThreadStore
114 ensureIOManagerIsRunning :: IO ()
115 ensureIOManagerIsRunning
116 | not threaded = return ()
117 | otherwise = modifyMVar_ ioManager $ \old -> do
120 writeIORef eventManager $ Just mgr
121 !t <- forkIO $ loop mgr
122 labelThread t "IOManager"
129 ThreadFinished -> create
131 -- Sanity check: if the thread has died, there is a chance
132 -- that event manager is still alive. This could happend during
133 -- the fork, for example. In this case we should clean up
134 -- open pipes and everything else related to the event manager.
136 mem <- readIORef eventManager
139 Just em -> M.cleanup em
143 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool