    {-# LANGUAGE Unsafe #-}
    {-# LANGUAGE CPP
               , NoImplicitPrelude
               , ScopedTypeVariables
               , BangPatterns
      #-}

    module GHC.Internal.Event.Control
        (
        -- * Managing the IO manager
          Signal
        , ControlMessage(..)
        , Control
        , newControl
        , closeControl
        -- ** Control message reception
        , readControlMessage
        -- *** File descriptors
        , controlReadFd
        , controlWriteFd
        , wakeupReadFd
        -- ** Control message sending
        , sendWakeup
        , sendDie
        -- * Utilities
        , setNonBlockingFD
        ) where

    #include <ghcplatform.h>
    #include "EventConfig.h"

    import GHC.Internal.Base
    import GHC.Internal.IORef
    import GHC.Internal.Conc.Signal (Signal)
    import GHC.Internal.Real (fromIntegral)
    import GHC.Internal.Show (Show)
    import GHC.Internal.Word (Word8)
    import GHC.Internal.Foreign.C.Error (throwErrnoIfMinus1_, throwErrno, getErrno)
    import GHC.Internal.Foreign.C.Types (CInt(..), CSize(..))
    import GHC.Internal.Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrBytes, withForeignPtr)
    import GHC.Internal.Foreign.Marshal.Alloc (alloca, allocaBytes)
    import GHC.Internal.Foreign.Marshal.Array (allocaArray)
    import GHC.Internal.Foreign.Ptr (castPtr)
    import GHC.Internal.Foreign.Storable (peek, peekElemOff, poke)
    import GHC.Internal.System.Posix.Internals (c_close, c_pipe, c_read, c_write,
                                   setCloseOnExec, setNonBlockingFD)
    import GHC.Internal.System.Posix.Types (Fd)

    #if defined(HAVE_EVENTFD)
    import GHC.Internal.Foreign.C.Error (throwErrnoIfMinus1, eBADF)
    import GHC.Internal.Foreign.C.Types (CULLong(..))
    #else
    import GHC.Internal.Foreign.C.Error (eAGAIN, eWOULDBLOCK, eBADF)
    #endif

    data ControlMessage = CMsgWakeup
                        | CMsgDie
                        | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8)
                                     {-# UNPACK #-} !Signal
        deriving ( ControlMessage -> ControlMessage -> Bool
    (ControlMessage -> ControlMessage -> Bool)
    -> (ControlMessage -> ControlMessage -> Bool) -> Eq ControlMessage
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: ControlMessage -> ControlMessage -> Bool
    == :: ControlMessage -> ControlMessage -> Bool
    $c/= :: ControlMessage -> ControlMessage -> Bool
    /= :: ControlMessage -> ControlMessage -> Bool
    Eq   -- ^ @since base-4.4.0.0
                 , Int -> ControlMessage -> ShowS
    [ControlMessage] -> ShowS
    ControlMessage -> String
    (Int -> ControlMessage -> ShowS)
    -> (ControlMessage -> String)
    -> ([ControlMessage] -> ShowS)
    -> Show ControlMessage
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> ControlMessage -> ShowS
    showsPrec :: Int -> ControlMessage -> ShowS
    $cshow :: ControlMessage -> String
    show :: ControlMessage -> String
    $cshowList :: [ControlMessage] -> ShowS
    showList :: [ControlMessage] -> ShowS
    Show -- ^ @since base-4.4.0.0
                 )

    -- | The structure used to tell the IO manager thread what to do.
    data Control = W {
          Control -> Fd
    controlReadFd  :: {-# UNPACK #-} !Fd
        , Control -> Fd
    controlWriteFd :: {-# UNPACK #-} !Fd
    #if defined(HAVE_EVENTFD)
        , Control -> Fd
    controlEventFd :: {-# UNPACK #-} !Fd
    #else
        , wakeupReadFd   :: {-# UNPACK #-} !Fd
        , wakeupWriteFd  :: {-# UNPACK #-} !Fd
    #endif
        , Control -> Bool
    didRegisterWakeupFd :: !Bool
          -- | Have this Control's fds been cleaned up?
        , Control -> IORef Bool
    controlIsDead  :: !(IORef Bool)
        }

    #if defined(HAVE_EVENTFD)
    wakeupReadFd :: Control -> Fd
    wakeupReadFd :: Control -> Fd
    wakeupReadFd = Control -> Fd
    controlEventFd
    {-# INLINE wakeupReadFd #-}
    #endif

    -- | Create the structure (usually a pipe) used for waking up the IO
    -- manager thread from another thread.
    newControl :: Bool -> IO Control
    newControl :: Bool -> IO Control
    newControl Bool
    shouldRegister = Int -> (Ptr CInt -> IO Control) -> IO Control
    forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
    allocaArray Int
    2 ((Ptr CInt -> IO Control) -> IO Control)
    -> (Ptr CInt -> IO Control) -> IO Control
    forall a b. (a -> b) -> a -> b
    $ \Ptr CInt
    fds -> do
      let createPipe :: IO (CInt, CInt)
    createPipe = do
            String -> IO CInt -> IO ()
    forall a. (Eq a, Num a) => String -> IO a -> IO ()
    throwErrnoIfMinus1_ String
    "pipe" (IO CInt -> IO ()) -> IO CInt -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Ptr CInt -> IO CInt
    c_pipe Ptr CInt
    fds
            rd <- Ptr CInt -> Int -> IO CInt
    forall a. Storable a => Ptr a -> Int -> IO a
    peekElemOff Ptr CInt
    fds Int
    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.
            setNonBlockingFD wr True
            setCloseOnExec rd
            setCloseOnExec wr
            return (rd, wr)
      (ctrl_rd, ctrl_wr) <- IO (CInt, CInt)
    createPipe
    #if defined(HAVE_EVENTFD)
      ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0
      setNonBlockingFD ev True
      setCloseOnExec ev
      when shouldRegister $ c_setIOManagerWakeupFd ev
    #else
      (wake_rd, wake_wr) <- createPipe
      when shouldRegister $ c_setIOManagerWakeupFd wake_wr
    #endif
      isDead <- newIORef False
      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
               , didRegisterWakeupFd = shouldRegister
               , controlIsDead  = isDead
               }

    -- | Close the control structure used by the IO manager thread.
    -- N.B. If this Control is the Control whose wakeup file was registered with
    -- the RTS, then *BEFORE* the wakeup file is closed, we must call
    -- c_setIOManagerWakeupFd (-1), so that the RTS does not try to use the wakeup
    -- file after it has been closed.
    --
    -- Note, however, that even if we do the above, this function is still racy
    -- since we do not synchronize between here and ioManagerWakeup.
    -- ioManagerWakeup ignores failures that arise from this case.
    closeControl :: Control -> IO ()
    closeControl :: Control -> IO ()
    closeControl Control
    w = do
      _ <- IORef Bool -> Bool -> IO Bool
    forall a. IORef a -> a -> IO a
    atomicSwapIORef (Control -> IORef Bool
    controlIsDead Control
    w) Bool
    True
      _ <- c_close . fromIntegral . controlReadFd $ w
      _ <- c_close . fromIntegral . controlWriteFd $ w
      when (didRegisterWakeupFd w) $ c_setIOManagerWakeupFd (-1)
    #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 :: Word8
    io_MANAGER_WAKEUP = Word8
    0xff
    io_MANAGER_DIE :: Word8
    io_MANAGER_DIE    = Word8
    0xfe

    #if !defined(HAVE_SIGNAL_H)
    readControlMessage :: Control -> Fd -> IO ControlMessage
    readControlMessage _ _ = errorWithoutStackTrace "readControlMessage"
    #else
    foreign import ccall "__hscore_sizeof_siginfo_t"
        sizeof_siginfo_t :: CSize

    readControlMessage :: Control -> Fd -> IO ControlMessage
    readControlMessage :: Control -> Fd -> IO ControlMessage
    readControlMessage Control
    ctrl Fd
    fd
        | Fd
    fd Fd -> Fd -> Bool
    forall a. Eq a => a -> a -> Bool
    == Control -> Fd
    wakeupReadFd Control
    ctrl = Int -> (Ptr Word8 -> IO ControlMessage) -> IO ControlMessage
    forall a b. Int -> (Ptr a -> IO b) -> IO b
    allocaBytes Int
    wakeupBufferSize ((Ptr Word8 -> IO ControlMessage) -> IO ControlMessage)
    -> (Ptr Word8 -> IO ControlMessage) -> IO ControlMessage
    forall a b. (a -> b) -> a -> b
    $ \Ptr Word8
    p -> do
                        String -> IO CSsize -> IO ()
    forall a. (Eq a, Num a) => String -> IO a -> IO ()
    throwErrnoIfMinus1_ String
    "readWakeupMessage" (IO CSsize -> IO ()) -> IO CSsize -> IO ()
    forall a b. (a -> b) -> a -> b
    $
                          CInt -> Ptr Word8 -> CSize -> IO CSsize
    c_read (Fd -> CInt
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Fd
    fd) Ptr Word8
    p (Int -> CSize
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    wakeupBufferSize)
                        ControlMessage -> IO ControlMessage
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ControlMessage
    CMsgWakeup
        | Bool
    otherwise =
            (Ptr Word8 -> IO ControlMessage) -> IO ControlMessage
    forall a b. Storable a => (Ptr a -> IO b) -> IO b
    alloca ((Ptr Word8 -> IO ControlMessage) -> IO ControlMessage)
    -> (Ptr Word8 -> IO ControlMessage) -> IO ControlMessage
    forall a b. (a -> b) -> a -> b
    $ \Ptr Word8
    p -> do
                String -> IO CSsize -> IO ()
    forall a. (Eq a, Num a) => String -> IO a -> IO ()
    throwErrnoIfMinus1_ String
    "readControlMessage" (IO CSsize -> IO ()) -> IO CSsize -> IO ()
    forall a b. (a -> b) -> a -> b
    $
                    CInt -> Ptr Word8 -> CSize -> IO CSsize
    c_read (Fd -> CInt
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Fd
    fd) Ptr Word8
    p CSize
    1
                s <- Ptr Word8 -> IO Word8
    forall a. Storable a => Ptr a -> IO a
    peek Ptr Word8
    p
                case s of
                    -- Wakeup messages shouldn't be sent on the control
                    -- file descriptor but we handle them anyway.
                    Word8
    _ | Word8
    s Word8 -> Word8 -> Bool
    forall a. Eq a => a -> a -> Bool
    == Word8
    io_MANAGER_WAKEUP -> ControlMessage -> IO ControlMessage
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ControlMessage
    CMsgWakeup
                    Word8
    _ | Word8
    s Word8 -> Word8 -> Bool
    forall a. Eq a => a -> a -> Bool
    == Word8
    io_MANAGER_DIE    -> ControlMessage -> IO ControlMessage
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ControlMessage
    CMsgDie
                    Word8
    _ -> do  -- Signal
                        fp <- Int -> IO (ForeignPtr Word8)
    forall a. Int -> IO (ForeignPtr a)
    mallocForeignPtrBytes (CSize -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral CSize
    sizeof_siginfo_t)
                        withForeignPtr fp $ \Ptr Word8
    p_siginfo -> do
                            r <- CInt -> Ptr Word8 -> CSize -> IO CSsize
    c_read (Fd -> CInt
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Fd
    fd) (Ptr Word8 -> Ptr Word8
    forall a b. Ptr a -> Ptr b
    castPtr Ptr Word8
    p_siginfo)
                                 CSize
    sizeof_siginfo_t
                            when (r /= fromIntegral sizeof_siginfo_t) $
                                errorWithoutStackTrace "failed to read siginfo_t"
                            let !s' = Word8 -> CInt
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word8
    s
                            return $ CMsgSignal fp s'

      where wakeupBufferSize :: Int
    wakeupBufferSize =
    #if defined(HAVE_EVENTFD)
                Int
    8
    #else
                4096
    #endif
    #endif

    sendWakeup :: Control -> IO ()
    #if defined(HAVE_EVENTFD)
    sendWakeup :: Control -> IO ()
    sendWakeup Control
    c = do
      n <- CInt -> CULLong -> IO CInt
    c_eventfd_write (Fd -> CInt
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Control -> Fd
    controlEventFd Control
    c)) CULLong
    1
      case n of
        CInt
    0     -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
        CInt
    _     -> do errno <- IO Errno
    getErrno
                    -- Check that Control is still alive if we failed, since it's
                    -- possible that someone cleaned up the fds behind our backs and
                    -- consequently eventfd_write failed with EBADF. If it is dead
                    -- then just swallow the error since we are shutting down
                    -- anyways. Otherwise we will see failures during shutdown from
                    -- setnumcapabilities001 (#12038)
                    isDead <- readIORef (controlIsDead c)
                    if isDead && errno == eBADF
                      then return ()
                      else throwErrno "sendWakeup"
    #else
    sendWakeup c = do
      n <- sendMessage (wakeupWriteFd c) CMsgWakeup
      case n of
        _ | n /= -1   -> return ()
          | otherwise -> do
                       errno <- getErrno
                       isDead <- readIORef (controlIsDead c)
                       case () of
                         _   -- Someone else has beat us to waking it up
                           | errno == eAGAIN          -> return ()
                           | errno == eWOULDBLOCK     -> return ()
                             -- we are shutting down
                           | errno == eBADF && isDead -> return ()
                             -- something bad happened
                           | otherwise                -> throwErrno "sendWakeup"
    #endif

    sendDie :: Control -> IO ()
    sendDie :: Control -> IO ()
    sendDie Control
    c = String -> IO Int -> IO ()
    forall a. (Eq a, Num a) => String -> IO a -> IO ()
    throwErrnoIfMinus1_ String
    "sendDie" (IO Int -> IO ()) -> IO Int -> IO ()
    forall a b. (a -> b) -> a -> b
    $
                Fd -> ControlMessage -> IO Int
    sendMessage (Control -> Fd
    controlWriteFd Control
    c) ControlMessage
    CMsgDie

    sendMessage :: Fd -> ControlMessage -> IO Int
    sendMessage :: Fd -> ControlMessage -> IO Int
    sendMessage Fd
    fd ControlMessage
    msg = (Ptr Word8 -> IO Int) -> IO Int
    forall a b. Storable a => (Ptr a -> IO b) -> IO b
    alloca ((Ptr Word8 -> IO Int) -> IO Int)
    -> (Ptr Word8 -> IO Int) -> IO Int
    forall a b. (a -> b) -> a -> b
    $ \Ptr Word8
    p -> do
      case ControlMessage
    msg of
        ControlMessage
    CMsgWakeup        -> Ptr Word8 -> Word8 -> IO ()
    forall a. Storable a => Ptr a -> a -> IO ()
    poke Ptr Word8
    p Word8
    io_MANAGER_WAKEUP
        ControlMessage
    CMsgDie           -> Ptr Word8 -> Word8 -> IO ()
    forall a. Storable a => Ptr a -> a -> IO ()
    poke Ptr Word8
    p Word8
    io_MANAGER_DIE
        CMsgSignal ForeignPtr Word8
    _fp CInt
    _s -> String -> IO ()
    forall a. String -> a
    errorWithoutStackTrace String
    "Signals can only be sent from within the RTS"
      CSsize -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (CSsize -> Int) -> IO CSsize -> IO Int
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` CInt -> Ptr Word8 -> CSize -> IO CSsize
    c_write (Fd -> CInt
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Fd
    fd) Ptr Word8
    p CSize
    1

    #if defined(HAVE_EVENTFD)
    foreign import ccall unsafe "sys/eventfd.h eventfd"
       c_eventfd :: CInt -> CInt -> IO CInt

    foreign import ccall unsafe "sys/eventfd.h eventfd_write"
       c_eventfd_write :: CInt -> CULLong -> IO CInt
    #endif

    #if defined(wasm32_HOST_ARCH)
    c_setIOManagerWakeupFd :: CInt -> IO ()
    c_setIOManagerWakeupFd _ = pure ()
    #else
    foreign import ccall unsafe "setIOManagerWakeupFd"
       c_setIOManagerWakeupFd :: CInt -> IO ()
    #endif