2 , ForeignFunctionInterface
8 module System.Event.Control
10 -- * Managing the IO manager
16 -- ** Control message reception
18 -- *** File descriptors
21 -- ** Control message sending
28 #include "EventConfig.h"
30 import Control.Monad (when)
31 import Foreign.ForeignPtr (ForeignPtr)
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)
48 #if defined(HAVE_EVENTFD)
49 import Data.Word (Word64)
50 import Foreign.C.Error (throwErrnoIfMinus1)
52 import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno)
55 data ControlMessage = CMsgWakeup
57 | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8)
58 {-# UNPACK #-} !Signal
61 -- | The structure used to tell the IO manager thread what to do.
63 controlReadFd :: {-# UNPACK #-} !Fd
64 , controlWriteFd :: {-# UNPACK #-} !Fd
65 #if defined(HAVE_EVENTFD)
66 , controlEventFd :: {-# UNPACK #-} !Fd
68 , wakeupReadFd :: {-# UNPACK #-} !Fd
69 , wakeupWriteFd :: {-# UNPACK #-} !Fd
73 #if defined(HAVE_EVENTFD)
74 wakeupReadFd :: Control -> Fd
75 wakeupReadFd = controlEventFd
76 {-# INLINE wakeupReadFd #-}
79 setNonBlock :: CInt -> IO ()
81 #if __GLASGOW_HASKELL__ >= 611
82 setNonBlockingFD fd True
87 -- | Create the structure (usually a pipe) used for waking up the IO
88 -- manager thread from another thread.
89 newControl :: IO Control
90 newControl = allocaArray 2 $ \fds -> do
92 throwErrnoIfMinus1_ "pipe" $ c_pipe fds
93 rd <- peekElemOff fds 0
94 wr <- peekElemOff fds 1
95 -- The write end must be non-blocking, since we may need to
96 -- poke the event manager from a signal handler.
101 (ctrl_rd, ctrl_wr) <- createPipe
102 c_setIOManagerControlFd ctrl_wr
103 #if defined(HAVE_EVENTFD)
104 ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0
107 c_setIOManagerWakeupFd ev
109 (wake_rd, wake_wr) <- createPipe
110 c_setIOManagerWakeupFd wake_wr
112 return W { controlReadFd = fromIntegral ctrl_rd
113 , controlWriteFd = fromIntegral ctrl_wr
114 #if defined(HAVE_EVENTFD)
115 , controlEventFd = fromIntegral ev
117 , wakeupReadFd = fromIntegral wake_rd
118 , wakeupWriteFd = fromIntegral wake_wr
122 -- | Close the control structure used by the IO manager thread.
123 closeControl :: Control -> IO ()
125 _ <- c_close . fromIntegral . controlReadFd $ w
126 _ <- c_close . fromIntegral . controlWriteFd $ w
127 #if defined(HAVE_EVENTFD)
128 _ <- c_close . fromIntegral . controlEventFd $ w
130 _ <- c_close . fromIntegral . wakeupReadFd $ w
131 _ <- c_close . fromIntegral . wakeupWriteFd $ w
135 io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8
136 io_MANAGER_WAKEUP = 0xff
137 io_MANAGER_DIE = 0xfe
139 foreign import ccall "__hscore_sizeof_siginfo_t"
140 sizeof_siginfo_t :: CSize
142 readControlMessage :: Control -> Fd -> IO ControlMessage
143 readControlMessage ctrl fd
144 | fd == wakeupReadFd ctrl = allocaBytes wakeupBufferSize $ \p -> do
145 throwErrnoIfMinus1_ "readWakeupMessage" $
146 c_read (fromIntegral fd) p (fromIntegral wakeupBufferSize)
150 throwErrnoIfMinus1_ "readControlMessage" $
151 c_read (fromIntegral fd) p 1
154 -- Wakeup messages shouldn't be sent on the control
155 -- file descriptor but we handle them anyway.
156 _ | s == io_MANAGER_WAKEUP -> return CMsgWakeup
157 _ | s == io_MANAGER_DIE -> return CMsgDie
159 fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)
160 withForeignPtr fp $ \p_siginfo -> do
161 r <- c_read (fromIntegral fd) (castPtr p_siginfo)
163 when (r /= fromIntegral sizeof_siginfo_t) $
164 error "failed to read siginfo_t"
165 let !s' = fromIntegral s
166 return $ CMsgSignal fp s'
168 where wakeupBufferSize =
169 #if defined(HAVE_EVENTFD)
175 sendWakeup :: Control -> IO ()
176 #if defined(HAVE_EVENTFD)
177 sendWakeup c = alloca $ \p -> do
179 throwErrnoIfMinus1_ "sendWakeup" $
180 c_write (fromIntegral (controlEventFd c)) (castPtr p) 8
183 n <- sendMessage (wakeupWriteFd c) CMsgWakeup
185 _ | n /= -1 -> return ()
188 when (errno /= eAGAIN && errno /= eWOULDBLOCK) $
189 throwErrno "sendWakeup"
192 sendDie :: Control -> IO ()
193 sendDie c = throwErrnoIfMinus1_ "sendDie" $
194 sendMessage (controlWriteFd c) CMsgDie
196 sendMessage :: Fd -> ControlMessage -> IO Int
197 sendMessage fd msg = alloca $ \p -> do
199 CMsgWakeup -> poke p io_MANAGER_WAKEUP
200 CMsgDie -> poke p io_MANAGER_DIE
201 CMsgSignal _fp _s -> error "Signals can only be sent from within the RTS"
202 fromIntegral `fmap` c_write (fromIntegral fd) p 1
204 #if defined(HAVE_EVENTFD)
205 foreign import ccall unsafe "sys/eventfd.h eventfd"
206 c_eventfd :: CInt -> CInt -> IO CInt
209 -- Used to tell the RTS how it can send messages to the I/O manager.
210 foreign import ccall "setIOManagerControlFd"
211 c_setIOManagerControlFd :: CInt -> IO ()
213 foreign import ccall "setIOManagerWakeupFd"
214 c_setIOManagerWakeupFd :: CInt -> IO ()