System/Event/Control.hs

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