System/Event/Control.hs

   1 {-# LANGUAGE CPP, ForeignFunctionInterface, NoImplicitPrelude,
   2     ScopedTypeVariables #-}
   3
   4 module System.Event.Control
   5     (
   6     -- * Managing the IO manager
   7       Signal
   8     , ControlMessage(..)
   9     , Control
  10     , newControl
  11     , closeControl
  12     -- ** Control message reception
  13     , readControlMessage
  14     -- *** File descriptors
  15     , controlReadFd
  16     , wakeupReadFd
  17     -- ** Control message sending
  18     , sendWakeup
  19     , sendDie
  20     -- * Utilities
  21     , setNonBlockingFD
  22     ) where
  23
  24 #include "EventConfig.h"
  25
  26 import Control.Monad (when)
  27 import Foreign.ForeignPtr (ForeignPtr)
  28 import GHC.Base
  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)
  44
  45 #if defined(HAVE_EVENTFD)
  46 import Data.Word (Word64)
  47 import Foreign.C.Error (throwErrnoIfMinus1)
  48 #else
  49 import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno)
  50 #endif
  51
  52 data ControlMessage = CMsgWakeup
  53                     | CMsgDie
  54                     | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8)
  55                                  {-# UNPACK #-} !Signal
  56     deriving (Eq, Show)
  57
  58 -- | The structure used to tell the IO manager thread what to do.
  59 data Control = W {
  60       controlReadFd  :: {-# UNPACK #-} !Fd
  61     , controlWriteFd :: {-# UNPACK #-} !Fd
  62 #if defined(HAVE_EVENTFD)
  63     , controlEventFd :: {-# UNPACK #-} !Fd
  64 #else
  65     , wakeupReadFd   :: {-# UNPACK #-} !Fd
  66     , wakeupWriteFd  :: {-# UNPACK #-} !Fd
  67 #endif
  68     } deriving (Show)
  69
  70 #if defined(HAVE_EVENTFD)
  71 wakeupReadFd :: Control -> Fd
  72 wakeupReadFd = controlEventFd
  73 {-# INLINE wakeupReadFd #-}
  74 #endif
  75
  76 setNonBlock :: CInt -> IO ()
  77 setNonBlock fd =
  78 #if __GLASGOW_HASKELL__ >= 611
  79   setNonBlockingFD fd True
  80 #else
  81   setNonBlockingFD fd
  82 #endif
  83
  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
  88   let createPipe = 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.
  94         setNonBlock wr
  95         setCloseOnExec rd
  96         setCloseOnExec wr
  97         return (rd, wr)
  98   (ctrl_rd, ctrl_wr) <- createPipe
  99   c_setIOManagerControlFd ctrl_wr
 100 #if defined(HAVE_EVENTFD)
 101   ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0
 102   setNonBlock ev
 103   setCloseOnExec ev
 104   c_setIOManagerWakeupFd ev
 105 #else
 106   (wake_rd, wake_wr) <- createPipe
 107   c_setIOManagerWakeupFd wake_wr
 108 #endif
 109   return W { controlReadFd  = fromIntegral ctrl_rd
 110            , controlWriteFd = fromIntegral ctrl_wr
 111 #if defined(HAVE_EVENTFD)
 112            , controlEventFd = fromIntegral ev
 113 #else
 114            , wakeupReadFd   = fromIntegral wake_rd
 115            , wakeupWriteFd  = fromIntegral wake_wr
 116 #endif
 117            }
 118
 119 -- | Close the control structure used by the IO manager thread.
 120 closeControl :: Control -> IO ()
 121 closeControl w = do
 122   _ <- c_close . fromIntegral . controlReadFd $ w
 123   _ <- c_close . fromIntegral . controlWriteFd $ w
 124 #if defined(HAVE_EVENTFD)
 125   _ <- c_close . fromIntegral . controlEventFd $ w
 126 #else
 127   _ <- c_close . fromIntegral . wakeupReadFd $ w
 128   _ <- c_close . fromIntegral . wakeupWriteFd $ w
 129 #endif
 130   return ()
 131
 132 io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8
 133 io_MANAGER_WAKEUP = 0xff
 134 io_MANAGER_DIE    = 0xfe
 135
 136 foreign import ccall "__hscore_sizeof_siginfo_t"
 137     sizeof_siginfo_t :: CSize
 138
 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)
 144                     return CMsgWakeup
 145     | otherwise =
 146         alloca $ \p -> do
 147             throwErrnoIfMinus1_ "readControlMessage" $
 148                 c_read (fromIntegral fd) p 1
 149             s <- peek p
 150             case s of
 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
 155                 _ -> do  -- Signal
 156                     fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)
 157                     withForeignPtr fp $ \p_siginfo -> do
 158                         r <- c_read (fromIntegral fd) (castPtr p_siginfo)
 159                              sizeof_siginfo_t
 160                         when (r /= fromIntegral sizeof_siginfo_t) $
 161                             error "failed to read siginfo_t"
 162                         let !s' = fromIntegral s
 163                         return $ CMsgSignal fp s'
 164
 165   where wakeupBufferSize =
 166 #if defined(HAVE_EVENTFD)
 167             8
 168 #else
 169             4096
 170 #endif
 171
 172 sendWakeup :: Control -> IO ()
 173 #if defined(HAVE_EVENTFD)
 174 sendWakeup c = alloca $ \p -> do
 175   poke p (1 :: Word64)
 176   throwErrnoIfMinus1_ "sendWakeup" $
 177     c_write (fromIntegral (controlEventFd c)) (castPtr p) 8
 178 #else
 179 sendWakeup c = do
 180   n <- sendMessage (wakeupWriteFd c) CMsgWakeup
 181   case n of
 182     _ | n /= -1   -> return ()
 183       | otherwise -> do
 184                    errno <- getErrno
 185                    when (errno /= eAGAIN && errno /= eWOULDBLOCK) $
 186                      throwErrno "sendWakeup"
 187 #endif
 188
 189 sendDie :: Control -> IO ()
 190 sendDie c = throwErrnoIfMinus1_ "sendDie" $
 191             sendMessage (controlWriteFd c) CMsgDie
 192
 193 sendMessage :: Fd -> ControlMessage -> IO Int
 194 sendMessage fd msg = alloca $ \p -> do
 195   case msg of
 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
 200
 201 #if defined(HAVE_EVENTFD)
 202 foreign import ccall unsafe "sys/eventfd.h eventfd"
 203    c_eventfd :: CInt -> CInt -> IO CInt
 204 #endif
 205
 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 ()
 209
 210 foreign import ccall "setIOManagerWakeupFd"
 211    c_setIOManagerWakeupFd :: CInt -> IO ()