System/Event/Control.hs

   1 {-# LANGUAGE CPP
   2            , ForeignFunctionInterface
   3            , NoImplicitPrelude
   4            , ScopedTypeVariables
   5            , BangPatterns
   6   #-}
   7
   8 module System.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     , wakeupReadFd
  21     -- ** Control message sending
  22     , sendWakeup
  23     , sendDie
  24     -- * Utilities
  25     , setNonBlockingFD
  26     ) where
  27
  28 #include "EventConfig.h"
  29
  30 import Control.Monad (when)
  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 Data.Word (Word64)
  50 import Foreign.C.Error (throwErrnoIfMinus1)
  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 setNonBlock :: CInt -> IO ()
  80 setNonBlock fd =
  81 #if __GLASGOW_HASKELL__ >= 611
  82   setNonBlockingFD fd True
  83 #else
  84   setNonBlockingFD fd
  85 #endif
  86
  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
  91   let createPipe = 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.
  97         setNonBlock wr
  98         setCloseOnExec rd
  99         setCloseOnExec wr
 100         return (rd, wr)
 101   (ctrl_rd, ctrl_wr) <- createPipe
 102   c_setIOManagerControlFd ctrl_wr
 103 #if defined(HAVE_EVENTFD)
 104   ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0
 105   setNonBlock ev
 106   setCloseOnExec ev
 107   c_setIOManagerWakeupFd ev
 108 #else
 109   (wake_rd, wake_wr) <- createPipe
 110   c_setIOManagerWakeupFd wake_wr
 111 #endif
 112   return W { controlReadFd  = fromIntegral ctrl_rd
 113            , controlWriteFd = fromIntegral ctrl_wr
 114 #if defined(HAVE_EVENTFD)
 115            , controlEventFd = fromIntegral ev
 116 #else
 117            , wakeupReadFd   = fromIntegral wake_rd
 118            , wakeupWriteFd  = fromIntegral wake_wr
 119 #endif
 120            }
 121
 122 -- | Close the control structure used by the IO manager thread.
 123 closeControl :: Control -> IO ()
 124 closeControl w = do
 125   _ <- c_close . fromIntegral . controlReadFd $ w
 126   _ <- c_close . fromIntegral . controlWriteFd $ w
 127 #if defined(HAVE_EVENTFD)
 128   _ <- c_close . fromIntegral . controlEventFd $ w
 129 #else
 130   _ <- c_close . fromIntegral . wakeupReadFd $ w
 131   _ <- c_close . fromIntegral . wakeupWriteFd $ w
 132 #endif
 133   return ()
 134
 135 io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8
 136 io_MANAGER_WAKEUP = 0xff
 137 io_MANAGER_DIE    = 0xfe
 138
 139 foreign import ccall "__hscore_sizeof_siginfo_t"
 140     sizeof_siginfo_t :: CSize
 141
 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)
 147                     return CMsgWakeup
 148     | otherwise =
 149         alloca $ \p -> do
 150             throwErrnoIfMinus1_ "readControlMessage" $
 151                 c_read (fromIntegral fd) p 1
 152             s <- peek p
 153             case s of
 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
 158                 _ -> do  -- Signal
 159                     fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)
 160                     withForeignPtr fp $ \p_siginfo -> do
 161                         r <- c_read (fromIntegral fd) (castPtr p_siginfo)
 162                              sizeof_siginfo_t
 163                         when (r /= fromIntegral sizeof_siginfo_t) $
 164                             error "failed to read siginfo_t"
 165                         let !s' = fromIntegral s
 166                         return $ CMsgSignal fp s'
 167
 168   where wakeupBufferSize =
 169 #if defined(HAVE_EVENTFD)
 170             8
 171 #else
 172             4096
 173 #endif
 174
 175 sendWakeup :: Control -> IO ()
 176 #if defined(HAVE_EVENTFD)
 177 sendWakeup c = alloca $ \p -> do
 178   poke p (1 :: Word64)
 179   throwErrnoIfMinus1_ "sendWakeup" $
 180     c_write (fromIntegral (controlEventFd c)) (castPtr p) 8
 181 #else
 182 sendWakeup c = do
 183   n <- sendMessage (wakeupWriteFd c) CMsgWakeup
 184   case n of
 185     _ | n /= -1   -> return ()
 186       | otherwise -> do
 187                    errno <- getErrno
 188                    when (errno /= eAGAIN && errno /= eWOULDBLOCK) $
 189                      throwErrno "sendWakeup"
 190 #endif
 191
 192 sendDie :: Control -> IO ()
 193 sendDie c = throwErrnoIfMinus1_ "sendDie" $
 194             sendMessage (controlWriteFd c) CMsgDie
 195
 196 sendMessage :: Fd -> ControlMessage -> IO Int
 197 sendMessage fd msg = alloca $ \p -> do
 198   case msg of
 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
 203
 204 #if defined(HAVE_EVENTFD)
 205 foreign import ccall unsafe "sys/eventfd.h eventfd"
 206    c_eventfd :: CInt -> CInt -> IO CInt
 207 #endif
 208
 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 ()
 212
 213 foreign import ccall "setIOManagerWakeupFd"
 214    c_setIOManagerWakeupFd :: CInt -> IO ()