{-# 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