Update base for latest Safe Haskell.
[packages/base.git] / GHC / Event / Thread.hs
1 {-# LANGUAGE Trustworthy #-}
2 {-# LANGUAGE BangPatterns, ForeignFunctionInterface, NoImplicitPrelude #-}
3
4 module GHC.Event.Thread
5 ( getSystemEventManager
6 , ensureIOManagerIsRunning
7 , threadWaitRead
8 , threadWaitWrite
9 , closeFdWith
10 , threadDelay
11 , registerDelay
12 ) where
13
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)
18 import GHC.Base
19 import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO,
20 labelThread, modifyMVar_, newTVar, sharedCAF,
21 threadStatus, writeTVar)
22 import GHC.IO (mask_, onException)
23 import GHC.IO.Exception (ioError)
24 import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
25 import GHC.Event.Internal (eventIs, evtClose)
26 import GHC.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,
27 new, registerFd, unregisterFd_, registerTimeout)
28 import qualified GHC.Event.Manager as M
29 import System.IO.Unsafe (unsafePerformIO)
30 import System.Posix.Types (Fd)
31
32 -- | Suspends the current thread for a given number of microseconds
33 -- (GHC only).
34 --
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 = mask_ $ do
40 Just mgr <- getSystemEventManager
41 m <- newEmptyMVar
42 reg <- registerTimeout mgr usecs (putMVar m ())
43 takeMVar m `onException` M.unregisterTimeout mgr reg
44
45 -- | Set the value of returned TVar to True after a given number of
46 -- microseconds. The caveats associated with threadDelay also apply.
47 --
48 registerDelay :: Int -> IO (TVar Bool)
49 registerDelay usecs = do
50 t <- atomically $ newTVar False
51 Just mgr <- getSystemEventManager
52 _ <- registerTimeout mgr usecs . atomically $ writeTVar t True
53 return t
54
55 -- | Block the current thread until data is available to read from the
56 -- given file descriptor.
57 --
58 -- This will throw an 'IOError' if the file descriptor was closed
59 -- while this thread was blocked. To safely close a file descriptor
60 -- that has been used with 'threadWaitRead', use 'closeFdWith'.
61 threadWaitRead :: Fd -> IO ()
62 threadWaitRead = threadWait evtRead
63 {-# INLINE threadWaitRead #-}
64
65 -- | Block the current thread until the given file descriptor can
66 -- accept data to write.
67 --
68 -- This will throw an 'IOError' if the file descriptor was closed
69 -- while this thread was blocked. To safely close a file descriptor
70 -- that has been used with 'threadWaitWrite', use 'closeFdWith'.
71 threadWaitWrite :: Fd -> IO ()
72 threadWaitWrite = threadWait evtWrite
73 {-# INLINE threadWaitWrite #-}
74
75 -- | Close a file descriptor in a concurrency-safe way.
76 --
77 -- Any threads that are blocked on the file descriptor via
78 -- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having
79 -- IO exceptions thrown.
80 closeFdWith :: (Fd -> IO ()) -- ^ Action that performs the close.
81 -> Fd -- ^ File descriptor to close.
82 -> IO ()
83 closeFdWith close fd = do
84 Just mgr <- getSystemEventManager
85 M.closeFd mgr close fd
86
87 threadWait :: Event -> Fd -> IO ()
88 threadWait evt fd = mask_ $ do
89 m <- newEmptyMVar
90 Just mgr <- getSystemEventManager
91 reg <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> putMVar m e) fd evt
92 evt' <- takeMVar m `onException` unregisterFd_ mgr reg
93 if evt' `eventIs` evtClose
94 then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing
95 else return ()
96
97 -- | Retrieve the system event manager.
98 --
99 -- This function always returns 'Just' the system event manager when using the
100 -- threaded RTS and 'Nothing' otherwise.
101 getSystemEventManager :: IO (Maybe EventManager)
102 getSystemEventManager = readIORef eventManager
103
104 foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore"
105 getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a)
106
107 eventManager :: IORef (Maybe EventManager)
108 eventManager = unsafePerformIO $ do
109 em <- newIORef Nothing
110 sharedCAF em getOrSetSystemEventThreadEventManagerStore
111 {-# NOINLINE eventManager #-}
112
113 foreign import ccall unsafe "getOrSetSystemEventThreadIOManagerThreadStore"
114 getOrSetSystemEventThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a)
115
116 {-# NOINLINE ioManager #-}
117 ioManager :: MVar (Maybe ThreadId)
118 ioManager = unsafePerformIO $ do
119 m <- newMVar Nothing
120 sharedCAF m getOrSetSystemEventThreadIOManagerThreadStore
121
122 ensureIOManagerIsRunning :: IO ()
123 ensureIOManagerIsRunning
124 | not threaded = return ()
125 | otherwise = modifyMVar_ ioManager $ \old -> do
126 let create = do
127 !mgr <- new
128 writeIORef eventManager $ Just mgr
129 !t <- forkIO $ loop mgr
130 labelThread t "IOManager"
131 return $ Just t
132 case old of
133 Nothing -> create
134 st@(Just t) -> do
135 s <- threadStatus t
136 case s of
137 ThreadFinished -> create
138 ThreadDied -> do
139 -- Sanity check: if the thread has died, there is a chance
140 -- that event manager is still alive. This could happend during
141 -- the fork, for example. In this case we should clean up
142 -- open pipes and everything else related to the event manager.
143 -- See #4449
144 mem <- readIORef eventManager
145 _ <- case mem of
146 Nothing -> return ()
147 Just em -> M.cleanup em
148 create
149 _other -> return st
150
151 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool