1 {-# LANGUAGE CPP, ForeignFunctionInterface, NoImplicitPrelude,
2 ScopedTypeVariables #-}
4 module System.Event.Control
6 -- * Managing the IO manager
12 -- ** Control message reception
14 -- *** File descriptors
17 -- ** Control message sending
24 #include "EventConfig.h"
26 import Control.Monad (when)
27 import Foreign.ForeignPtr (ForeignPtr)
29 import GHC.Conc.Signal (Signal)
30 import GHC.Real (fromIntegral)
31 import GHC.Show (Show)
32 import GHC.Word (Word8)
33 import Foreign.C.Error (throwErrnoIfMinus1_)
34 import Foreign.C.Types (CInt, CSize)
35 import Foreign.ForeignPtr (mallocForeignPtrBytes, withForeignPtr)
36 import Foreign.Marshal (alloca, allocaBytes)
37 import Foreign.Marshal.Array (allocaArray)
38 import Foreign.Ptr (castPtr)
39 import Foreign.Storable (peek, peekElemOff, poke)
40 import System.Posix.Internals (c_close, c_pipe, c_read, c_write,
41 setCloseOnExec, setNonBlockingFD)
42 import System.Posix.Types (Fd)
44 #if defined(HAVE_EVENTFD)
45 import Data.Word (Word64)
46 import Foreign.C.Error (throwErrnoIfMinus1)
48 import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno)
51 data ControlMessage = CMsgWakeup
53 | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8)
54 {-# UNPACK #-} !Signal
57 -- | The structure used to tell the IO manager thread what to do.
59 controlReadFd :: {-# UNPACK #-} !Fd
60 , controlWriteFd :: {-# UNPACK #-} !Fd
61 #if defined(HAVE_EVENTFD)
62 , controlEventFd :: {-# UNPACK #-} !Fd
64 , wakeupReadFd :: {-# UNPACK #-} !Fd
65 , wakeupWriteFd :: {-# UNPACK #-} !Fd
69 #if defined(HAVE_EVENTFD)
70 wakeupReadFd :: Control -> Fd
71 wakeupReadFd = controlEventFd
72 {-# INLINE wakeupReadFd #-}
75 setNonBlock :: CInt -> IO ()
77 #if __GLASGOW_HASKELL__ >= 611
78 setNonBlockingFD fd True
83 -- | Create the structure (usually a pipe) used for waking up the IO
84 -- manager thread from another thread.
85 newControl :: IO Control
86 newControl = allocaArray 2 $ \fds -> do
88 throwErrnoIfMinus1_ "pipe" $ c_pipe fds
89 rd <- peekElemOff fds 0
90 wr <- peekElemOff fds 1
91 -- The write end must be non-blocking, since we may need to
92 -- poke the event manager from a signal handler.
97 (ctrl_rd, ctrl_wr) <- createPipe
98 c_setIOManagerControlFd ctrl_wr
99 #if defined(HAVE_EVENTFD)
100 ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0
103 c_setIOManagerWakeupFd ev
105 (wake_rd, wake_wr) <- createPipe
106 c_setIOManagerWakeupFd wake_wr
108 return W { controlReadFd = fromIntegral ctrl_rd
109 , controlWriteFd = fromIntegral ctrl_wr
110 #if defined(HAVE_EVENTFD)
111 , controlEventFd = fromIntegral ev
113 , wakeupReadFd = fromIntegral wake_rd
114 , wakeupWriteFd = fromIntegral wake_wr
118 -- | Close the control structure used by the IO manager thread.
119 closeControl :: Control -> IO ()
121 _ <- c_close . fromIntegral . controlReadFd $ w
122 _ <- c_close . fromIntegral . controlWriteFd $ w
123 #if defined(HAVE_EVENTFD)
124 _ <- c_close . fromIntegral . controlEventFd $ w
126 _ <- c_close . fromIntegral . wakeupReadFd $ w
127 _ <- c_close . fromIntegral . wakeupWriteFd $ w
131 io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8
132 io_MANAGER_WAKEUP = 0xff
133 io_MANAGER_DIE = 0xfe
135 foreign import ccall "__hscore_sizeof_siginfo_t"
136 sizeof_siginfo_t :: CSize
138 readControlMessage :: Control -> Fd -> IO ControlMessage
139 readControlMessage ctrl fd
140 | fd == wakeupReadFd ctrl = allocaBytes wakeupBufferSize $ \p -> do
141 throwErrnoIfMinus1_ "readWakeupMessage" $
142 c_read (fromIntegral fd) p (fromIntegral wakeupBufferSize)
146 throwErrnoIfMinus1_ "readControlMessage" $
147 c_read (fromIntegral fd) p 1
150 -- Wakeup messages shouldn't be sent on the control
151 -- file descriptor but we handle them anyway.
152 _ | s == io_MANAGER_WAKEUP -> return CMsgWakeup
153 _ | s == io_MANAGER_DIE -> return CMsgDie
155 fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)
156 withForeignPtr fp $ \p_siginfo -> do
157 r <- c_read (fromIntegral fd) (castPtr p_siginfo)
159 when (r /= fromIntegral sizeof_siginfo_t) $
160 error "failed to read siginfo_t"
161 let !s' = fromIntegral s
162 return $ CMsgSignal fp s'
164 where wakeupBufferSize =
165 #if defined(HAVE_EVENTFD)
171 sendWakeup :: Control -> IO ()
172 #if defined(HAVE_EVENTFD)
173 sendWakeup c = alloca $ \p -> do
175 throwErrnoIfMinus1_ "sendWakeup" $
176 c_write (fromIntegral (controlEventFd c)) (castPtr p) 8
179 n <- sendMessage (wakeupWriteFd c) CMsgWakeup
181 _ | n /= -1 -> return ()
184 when (errno /= eAGAIN && errno /= eWOULDBLOCK) $
185 throwErrno "sendWakeup"
188 sendDie :: Control -> IO ()
189 sendDie c = throwErrnoIfMinus1_ "sendDie" $
190 sendMessage (controlWriteFd c) CMsgDie
192 sendMessage :: Fd -> ControlMessage -> IO Int
193 sendMessage fd msg = alloca $ \p -> do
195 CMsgWakeup -> poke p io_MANAGER_WAKEUP
196 CMsgDie -> poke p io_MANAGER_DIE
197 CMsgSignal _fp _s -> error "Signals can only be sent from within the RTS"
198 fromIntegral `fmap` c_write (fromIntegral fd) p 1
200 #if defined(HAVE_EVENTFD)
201 foreign import ccall unsafe "sys/eventfd.h eventfd"
202 c_eventfd :: CInt -> CInt -> IO CInt
205 -- Used to tell the RTS how it can send messages to the I/O manager.
206 foreign import ccall "setIOManagerControlFd"
207 c_setIOManagerControlFd :: CInt -> IO ()
209 foreign import ccall "setIOManagerWakeupFd"
210 c_setIOManagerWakeupFd :: CInt -> IO ()