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.Num (Num(..))
31 import GHC.Real (fromIntegral)
32 import GHC.Show (Show)
33 import GHC.Word (Word8)
34 import Foreign.C.Error (throwErrnoIfMinus1_)
35 import Foreign.C.Types (CInt, CSize)
36 import Foreign.ForeignPtr (mallocForeignPtrBytes, withForeignPtr)
37 import Foreign.Marshal (alloca, allocaBytes)
38 import Foreign.Marshal.Array (allocaArray)
39 import Foreign.Ptr (castPtr)
40 import Foreign.Storable (peek, peekElemOff, poke)
41 import System.Posix.Internals (c_close, c_pipe, c_read, c_write,
42 setCloseOnExec, setNonBlockingFD)
43 import System.Posix.Types (Fd)
45 #if defined(HAVE_EVENTFD)
46 import Data.Word (Word64)
47 import Foreign.C.Error (throwErrnoIfMinus1)
49 import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno)
52 data ControlMessage = CMsgWakeup
54 | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8)
55 {-# UNPACK #-} !Signal
58 -- | The structure used to tell the IO manager thread what to do.
60 controlReadFd :: {-# UNPACK #-} !Fd
61 , controlWriteFd :: {-# UNPACK #-} !Fd
62 #if defined(HAVE_EVENTFD)
63 , controlEventFd :: {-# UNPACK #-} !Fd
65 , wakeupReadFd :: {-# UNPACK #-} !Fd
66 , wakeupWriteFd :: {-# UNPACK #-} !Fd
70 #if defined(HAVE_EVENTFD)
71 wakeupReadFd :: Control -> Fd
72 wakeupReadFd = controlEventFd
73 {-# INLINE wakeupReadFd #-}
76 setNonBlock :: CInt -> IO ()
78 #if __GLASGOW_HASKELL__ >= 611
79 setNonBlockingFD fd True
84 -- | Create the structure (usually a pipe) used for waking up the IO
85 -- manager thread from another thread.
86 newControl :: IO Control
87 newControl = allocaArray 2 $ \fds -> do
89 throwErrnoIfMinus1_ "pipe" $ c_pipe fds
90 rd <- peekElemOff fds 0
91 wr <- peekElemOff fds 1
92 -- The write end must be non-blocking, since we may need to
93 -- poke the event manager from a signal handler.
98 (ctrl_rd, ctrl_wr) <- createPipe
99 c_setIOManagerControlFd ctrl_wr
100 #if defined(HAVE_EVENTFD)
101 ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0
104 c_setIOManagerWakeupFd ev
106 (wake_rd, wake_wr) <- createPipe
107 c_setIOManagerWakeupFd wake_wr
109 return W { controlReadFd = fromIntegral ctrl_rd
110 , controlWriteFd = fromIntegral ctrl_wr
111 #if defined(HAVE_EVENTFD)
112 , controlEventFd = fromIntegral ev
114 , wakeupReadFd = fromIntegral wake_rd
115 , wakeupWriteFd = fromIntegral wake_wr
119 -- | Close the control structure used by the IO manager thread.
120 closeControl :: Control -> IO ()
122 _ <- c_close . fromIntegral . controlReadFd $ w
123 _ <- c_close . fromIntegral . controlWriteFd $ w
124 #if defined(HAVE_EVENTFD)
125 _ <- c_close . fromIntegral . controlEventFd $ w
127 _ <- c_close . fromIntegral . wakeupReadFd $ w
128 _ <- c_close . fromIntegral . wakeupWriteFd $ w
132 io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8
133 io_MANAGER_WAKEUP = 0xff
134 io_MANAGER_DIE = 0xfe
136 foreign import ccall "__hscore_sizeof_siginfo_t"
137 sizeof_siginfo_t :: CSize
139 readControlMessage :: Control -> Fd -> IO ControlMessage
140 readControlMessage ctrl fd
141 | fd == wakeupReadFd ctrl = allocaBytes wakeupBufferSize $ \p -> do
142 throwErrnoIfMinus1_ "readWakeupMessage" $
143 c_read (fromIntegral fd) p (fromIntegral wakeupBufferSize)
147 throwErrnoIfMinus1_ "readControlMessage" $
148 c_read (fromIntegral fd) p 1
151 -- Wakeup messages shouldn't be sent on the control
152 -- file descriptor but we handle them anyway.
153 _ | s == io_MANAGER_WAKEUP -> return CMsgWakeup
154 _ | s == io_MANAGER_DIE -> return CMsgDie
156 fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)
157 withForeignPtr fp $ \p_siginfo -> do
158 r <- c_read (fromIntegral fd) (castPtr p_siginfo)
160 when (r /= fromIntegral sizeof_siginfo_t) $
161 error "failed to read siginfo_t"
162 let !s' = fromIntegral s
163 return $ CMsgSignal fp s'
165 where wakeupBufferSize =
166 #if defined(HAVE_EVENTFD)
172 sendWakeup :: Control -> IO ()
173 #if defined(HAVE_EVENTFD)
174 sendWakeup c = alloca $ \p -> do
176 throwErrnoIfMinus1_ "sendWakeup" $
177 c_write (fromIntegral (controlEventFd c)) (castPtr p) 8
180 n <- sendMessage (wakeupWriteFd c) CMsgWakeup
182 _ | n /= -1 -> return ()
185 when (errno /= eAGAIN && errno /= eWOULDBLOCK) $
186 throwErrno "sendWakeup"
189 sendDie :: Control -> IO ()
190 sendDie c = throwErrnoIfMinus1_ "sendDie" $
191 sendMessage (controlWriteFd c) CMsgDie
193 sendMessage :: Fd -> ControlMessage -> IO Int
194 sendMessage fd msg = alloca $ \p -> do
196 CMsgWakeup -> poke p io_MANAGER_WAKEUP
197 CMsgDie -> poke p io_MANAGER_DIE
198 CMsgSignal _fp _s -> error "Signals can only be sent from within the RTS"
199 fromIntegral `fmap` c_write (fromIntegral fd) p 1
201 #if defined(HAVE_EVENTFD)
202 foreign import ccall unsafe "sys/eventfd.h eventfd"
203 c_eventfd :: CInt -> CInt -> IO CInt
206 -- Used to tell the RTS how it can send messages to the I/O manager.
207 foreign import ccall "setIOManagerControlFd"
208 c_setIOManagerControlFd :: CInt -> IO ()
210 foreign import ccall "setIOManagerWakeupFd"
211 c_setIOManagerWakeupFd :: CInt -> IO ()