Improve Safe Haskell bounds for changes to base over time
[ghc.git] / libraries / base / GHC / Event / Control.hs
1 {-# LANGUAGE Trustworthy #-}
2 {-# LANGUAGE CPP
3 , NoImplicitPrelude
4 , ScopedTypeVariables
5 , BangPatterns
6 #-}
7
8 module GHC.Event.Control
9 (
10 -- * Managing the IO manager
11 Signal
12 , ControlMessage(..)
13 , Control
14 , newControl
15 , closeControl
16 -- ** Control message reception
17 , readControlMessage
18 -- *** File descriptors
19 , controlReadFd
20 , controlWriteFd
21 , wakeupReadFd
22 -- ** Control message sending
23 , sendWakeup
24 , sendDie
25 -- * Utilities
26 , setNonBlockingFD
27 ) where
28
29 #include "EventConfig.h"
30
31 import Foreign.ForeignPtr (ForeignPtr)
32 import GHC.Base
33 import GHC.Conc.Signal (Signal)
34 import GHC.Real (fromIntegral)
35 import GHC.Show (Show)
36 import GHC.Word (Word8)
37 import Foreign.C.Error (throwErrnoIfMinus1_)
38 import Foreign.C.Types (CInt(..), CSize(..))
39 import Foreign.ForeignPtr (mallocForeignPtrBytes, withForeignPtr)
40 import Foreign.Marshal (alloca, allocaBytes)
41 import Foreign.Marshal.Array (allocaArray)
42 import Foreign.Ptr (castPtr)
43 import Foreign.Storable (peek, peekElemOff, poke)
44 import System.Posix.Internals (c_close, c_pipe, c_read, c_write,
45 setCloseOnExec, setNonBlockingFD)
46 import System.Posix.Types (Fd)
47
48 #if defined(HAVE_EVENTFD)
49 import Foreign.C.Error (throwErrnoIfMinus1)
50 import Foreign.C.Types (CULLong(..))
51 #else
52 import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno)
53 #endif
54
55 data ControlMessage = CMsgWakeup
56 | CMsgDie
57 | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8)
58 {-# UNPACK #-} !Signal
59 deriving (Eq, Show)
60
61 -- | The structure used to tell the IO manager thread what to do.
62 data Control = W {
63 controlReadFd :: {-# UNPACK #-} !Fd
64 , controlWriteFd :: {-# UNPACK #-} !Fd
65 #if defined(HAVE_EVENTFD)
66 , controlEventFd :: {-# UNPACK #-} !Fd
67 #else
68 , wakeupReadFd :: {-# UNPACK #-} !Fd
69 , wakeupWriteFd :: {-# UNPACK #-} !Fd
70 #endif
71 } deriving (Show)
72
73 #if defined(HAVE_EVENTFD)
74 wakeupReadFd :: Control -> Fd
75 wakeupReadFd = controlEventFd
76 {-# INLINE wakeupReadFd #-}
77 #endif
78
79 -- | Create the structure (usually a pipe) used for waking up the IO
80 -- manager thread from another thread.
81 newControl :: Bool -> IO Control
82 newControl shouldRegister = allocaArray 2 $ \fds -> do
83 let createPipe = do
84 throwErrnoIfMinus1_ "pipe" $ c_pipe fds
85 rd <- peekElemOff fds 0
86 wr <- peekElemOff fds 1
87 -- The write end must be non-blocking, since we may need to
88 -- poke the event manager from a signal handler.
89 setNonBlockingFD wr True
90 setCloseOnExec rd
91 setCloseOnExec wr
92 return (rd, wr)
93 (ctrl_rd, ctrl_wr) <- createPipe
94 #if defined(HAVE_EVENTFD)
95 ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0
96 setNonBlockingFD ev True
97 setCloseOnExec ev
98 when shouldRegister $ c_setIOManagerWakeupFd ev
99 #else
100 (wake_rd, wake_wr) <- createPipe
101 when shouldRegister $ c_setIOManagerWakeupFd wake_wr
102 #endif
103 return W { controlReadFd = fromIntegral ctrl_rd
104 , controlWriteFd = fromIntegral ctrl_wr
105 #if defined(HAVE_EVENTFD)
106 , controlEventFd = fromIntegral ev
107 #else
108 , wakeupReadFd = fromIntegral wake_rd
109 , wakeupWriteFd = fromIntegral wake_wr
110 #endif
111 }
112
113 -- | Close the control structure used by the IO manager thread.
114 closeControl :: Control -> IO ()
115 closeControl w = do
116 _ <- c_close . fromIntegral . controlReadFd $ w
117 _ <- c_close . fromIntegral . controlWriteFd $ w
118 #if defined(HAVE_EVENTFD)
119 _ <- c_close . fromIntegral . controlEventFd $ w
120 #else
121 _ <- c_close . fromIntegral . wakeupReadFd $ w
122 _ <- c_close . fromIntegral . wakeupWriteFd $ w
123 #endif
124 return ()
125
126 io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8
127 io_MANAGER_WAKEUP = 0xff
128 io_MANAGER_DIE = 0xfe
129
130 foreign import ccall "__hscore_sizeof_siginfo_t"
131 sizeof_siginfo_t :: CSize
132
133 readControlMessage :: Control -> Fd -> IO ControlMessage
134 readControlMessage ctrl fd
135 | fd == wakeupReadFd ctrl = allocaBytes wakeupBufferSize $ \p -> do
136 throwErrnoIfMinus1_ "readWakeupMessage" $
137 c_read (fromIntegral fd) p (fromIntegral wakeupBufferSize)
138 return CMsgWakeup
139 | otherwise =
140 alloca $ \p -> do
141 throwErrnoIfMinus1_ "readControlMessage" $
142 c_read (fromIntegral fd) p 1
143 s <- peek p
144 case s of
145 -- Wakeup messages shouldn't be sent on the control
146 -- file descriptor but we handle them anyway.
147 _ | s == io_MANAGER_WAKEUP -> return CMsgWakeup
148 _ | s == io_MANAGER_DIE -> return CMsgDie
149 _ -> do -- Signal
150 fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)
151 withForeignPtr fp $ \p_siginfo -> do
152 r <- c_read (fromIntegral fd) (castPtr p_siginfo)
153 sizeof_siginfo_t
154 when (r /= fromIntegral sizeof_siginfo_t) $
155 error "failed to read siginfo_t"
156 let !s' = fromIntegral s
157 return $ CMsgSignal fp s'
158
159 where wakeupBufferSize =
160 #if defined(HAVE_EVENTFD)
161 8
162 #else
163 4096
164 #endif
165
166 sendWakeup :: Control -> IO ()
167 #if defined(HAVE_EVENTFD)
168 sendWakeup c =
169 throwErrnoIfMinus1_ "sendWakeup" $
170 c_eventfd_write (fromIntegral (controlEventFd c)) 1
171 #else
172 sendWakeup c = do
173 n <- sendMessage (wakeupWriteFd c) CMsgWakeup
174 case n of
175 _ | n /= -1 -> return ()
176 | otherwise -> do
177 errno <- getErrno
178 when (errno /= eAGAIN && errno /= eWOULDBLOCK) $
179 throwErrno "sendWakeup"
180 #endif
181
182 sendDie :: Control -> IO ()
183 sendDie c = throwErrnoIfMinus1_ "sendDie" $
184 sendMessage (controlWriteFd c) CMsgDie
185
186 sendMessage :: Fd -> ControlMessage -> IO Int
187 sendMessage fd msg = alloca $ \p -> do
188 case msg of
189 CMsgWakeup -> poke p io_MANAGER_WAKEUP
190 CMsgDie -> poke p io_MANAGER_DIE
191 CMsgSignal _fp _s -> error "Signals can only be sent from within the RTS"
192 fromIntegral `fmap` c_write (fromIntegral fd) p 1
193
194 #if defined(HAVE_EVENTFD)
195 foreign import ccall unsafe "sys/eventfd.h eventfd"
196 c_eventfd :: CInt -> CInt -> IO CInt
197
198 foreign import ccall unsafe "sys/eventfd.h eventfd_write"
199 c_eventfd_write :: CInt -> CULLong -> IO CInt
200 #endif
201
202 foreign import ccall unsafe "setIOManagerWakeupFd"
203 c_setIOManagerWakeupFd :: CInt -> IO ()