content: {-# LANGUAGE Unsafe #-}
  {-# LANGUAGE CPP
             , ForeignFunctionInterface
             , NoImplicitPrelude
             , ScopedTypeVariables
             , BangPatterns
    #-}
  
  module GHC.Event.Control
      (
      -- * Managing the IO manager
        Signal
      , ControlMessage(..)
      , Control
      , newControl
      , closeControl
      -- ** Control message reception
      , readControlMessage
      -- *** File descriptors
      , controlReadFd
      , wakeupReadFd
      -- ** Control message sending
      , sendWakeup
      , sendDie
      -- * Utilities
      , setNonBlockingFD
      ) where
  
  #include "EventConfig.h"
  
  import Control.Monad (when)
  import Foreign.ForeignPtr (ForeignPtr)
  import GHC.Base
  import GHC.Conc.Signal (Signal)
  import GHC.Real (fromIntegral)
  import GHC.Show (Show)
  import GHC.Word (Word8)
  import Foreign.C.Error (throwErrnoIfMinus1_)
  import Foreign.C.Types (CInt(..), CSize(..))
  import Foreign.ForeignPtr (mallocForeignPtrBytes, withForeignPtr)
  import Foreign.Marshal (alloca, allocaBytes)
  import Foreign.Marshal.Array (allocaArray)
  import Foreign.Ptr (castPtr)
  import Foreign.Storable (peek, peekElemOff, poke)
  import System.Posix.Internals (c_close, c_pipe, c_read, c_write,
                                 setCloseOnExec, setNonBlockingFD)
  import System.Posix.Types (Fd)
  
  #if defined(HAVE_EVENTFD)
  import Data.Word (Word64)
  import Foreign.C.Error (throwErrnoIfMinus1)
  #else
  import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno)
  #endif
  
  data ControlMessage = CMsgWakeup
                      | CMsgDie
                      | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8)
                                   {-# UNPACK #-} !Signal
      deriving (Eq, Show)
  
  -- | The structure used to tell the IO manager thread what to do.
  data Control = W {
        controlReadFd  :: {-# UNPACK #-} !Fd
      , controlWriteFd :: {-# UNPACK #-} !Fd
  #if defined(HAVE_EVENTFD)
      , controlEventFd :: {-# UNPACK #-} !Fd
  #else
      , wakeupReadFd   :: {-# UNPACK #-} !Fd
      , wakeupWriteFd  :: {-# UNPACK #-} !Fd
  #endif
      } deriving (Show)
  
  #if defined(HAVE_EVENTFD)
  wakeupReadFd :: Control -> Fd
  wakeupReadFd = controlEventFd
  {-# INLINE wakeupReadFd #-}
  #endif
  
  setNonBlock :: CInt -> IO ()
  setNonBlock fd =
  #if __GLASGOW_HASKELL__ >= 611
    setNonBlockingFD fd True
  #else
    setNonBlockingFD fd
  #endif
  
  -- | Create the structure (usually a pipe) used for waking up the IO
  -- manager thread from another thread.
  newControl :: IO Control
  newControl = allocaArray 2 $ \fds -> do
    let createPipe = do
          throwErrnoIfMinus1_ "pipe" $ c_pipe fds
          rd <- peekElemOff fds 0
          wr <- peekElemOff fds 1
          -- The write end must be non-blocking, since we may need to
          -- poke the event manager from a signal handler.
          setNonBlock wr
          setCloseOnExec rd
          setCloseOnExec wr
          return (rd, wr)
    (ctrl_rd, ctrl_wr) <- createPipe
    c_setIOManagerControlFd ctrl_wr
  #if defined(HAVE_EVENTFD)
    ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0
    setNonBlock ev
    setCloseOnExec ev
    c_setIOManagerWakeupFd ev
  #else
    (wake_rd, wake_wr) <- createPipe
    c_setIOManagerWakeupFd wake_wr
  #endif
    return W { controlReadFd  = fromIntegral ctrl_rd
             , controlWriteFd = fromIntegral ctrl_wr
  #if defined(HAVE_EVENTFD)
             , controlEventFd = fromIntegral ev
  #else
             , wakeupReadFd   = fromIntegral wake_rd
             , wakeupWriteFd  = fromIntegral wake_wr
  #endif
             }
  
  -- | Close the control structure used by the IO manager thread.
  closeControl :: Control -> IO ()
  closeControl w = do
    _ <- c_close . fromIntegral . controlReadFd $ w
    _ <- c_close . fromIntegral . controlWriteFd $ w
  #if defined(HAVE_EVENTFD)
    _ <- c_close . fromIntegral . controlEventFd $ w
  #else
    _ <- c_close . fromIntegral . wakeupReadFd $ w
    _ <- c_close . fromIntegral . wakeupWriteFd $ w
  #endif
    return ()
  
  io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8
  io_MANAGER_WAKEUP = 0xff
  io_MANAGER_DIE    = 0xfe
  
  foreign import ccall "__hscore_sizeof_siginfo_t"
      sizeof_siginfo_t :: CSize
  
  readControlMessage :: Control -> Fd -> IO ControlMessage
  readControlMessage ctrl fd
      | fd == wakeupReadFd ctrl = allocaBytes wakeupBufferSize $ \p -> do
                      throwErrnoIfMinus1_ "readWakeupMessage" $
                        c_read (fromIntegral fd) p (fromIntegral wakeupBufferSize)
                      return CMsgWakeup
      | otherwise =
          alloca $ \p -> do
              throwErrnoIfMinus1_ "readControlMessage" $
                  c_read (fromIntegral fd) p 1
              s <- peek p
              case s of
                  -- Wakeup messages shouldn't be sent on the control
                  -- file descriptor but we handle them anyway.
                  _ | s == io_MANAGER_WAKEUP -> return CMsgWakeup
                  _ | s == io_MANAGER_DIE    -> return CMsgDie
                  _ -> do  -- Signal
                      fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)
                      withForeignPtr fp $ \p_siginfo -> do
                          r <- c_read (fromIntegral fd) (castPtr p_siginfo)
                               sizeof_siginfo_t
                          when (r /= fromIntegral sizeof_siginfo_t) $
                              error "failed to read siginfo_t"
                          let !s' = fromIntegral s
                          return $ CMsgSignal fp s'
  
    where wakeupBufferSize =
  #if defined(HAVE_EVENTFD)
              8
  #else
              4096
  #endif
  
  sendWakeup :: Control -> IO ()
  #if defined(HAVE_EVENTFD)
  sendWakeup c = alloca $ \p -> do
    poke p (1 :: Word64)
    throwErrnoIfMinus1_ "sendWakeup" $
      c_write (fromIntegral (controlEventFd c)) (castPtr p) 8
  #else
  sendWakeup c = do
    n <- sendMessage (wakeupWriteFd c) CMsgWakeup
    case n of
      _ | n /= -1   -> return ()
        | otherwise -> do
                     errno <- getErrno
                     when (errno /= eAGAIN && errno /= eWOULDBLOCK) $
                       throwErrno "sendWakeup"
  #endif
  
  sendDie :: Control -> IO ()
  sendDie c = throwErrnoIfMinus1_ "sendDie" $
              sendMessage (controlWriteFd c) CMsgDie
  
  sendMessage :: Fd -> ControlMessage -> IO Int
  sendMessage fd msg = alloca $ \p -> do
    case msg of
      CMsgWakeup        -> poke p io_MANAGER_WAKEUP
      CMsgDie           -> poke p io_MANAGER_DIE
      CMsgSignal _fp _s -> error "Signals can only be sent from within the RTS"
    fromIntegral `fmap` c_write (fromIntegral fd) p 1
  
  #if defined(HAVE_EVENTFD)
  foreign import ccall unsafe "sys/eventfd.h eventfd"
     c_eventfd :: CInt -> CInt -> IO CInt
  #endif
  
  -- Used to tell the RTS how it can send messages to the I/O manager.
  foreign import ccall "setIOManagerControlFd"
     c_setIOManagerControlFd :: CInt -> IO ()
  
  foreign import ccall "setIOManagerWakeupFd"
     c_setIOManagerWakeupFd :: CInt -> IO ()
  
  