    {-# LANGUAGE CPP, ForeignFunctionInterface, NoImplicitPrelude,
        ScopedTypeVariables #-}

    module System.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 ()