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

module GHC.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 "EventConfig.h"

import Foreign.ForeignPtr (ForeignPtr)
import GHC.Base
import GHC.IORef
import GHC.Conc.Signal (Signal)
import GHC.Real (fromIntegral)
import GHC.Show (Show)
import GHC.Word (Word8)
import Foreign.C.Error (throwErrnoIfMinus1_, throwErrno, getErrno)
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 Foreign.C.Error (throwErrnoIfMinus1, eBADF)
import Foreign.C.Types (CULLong(..))
#else
import Foreign.C.Error (eAGAIN, eWOULDBLOCK)
#endif

data ControlMessage = CMsgWakeup
                    | CMsgDie
                    | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8)
                                 {-# UNPACK #-} !Signal
    deriving ( Eq   -- ^ @since 4.4.0.0
             , Show -- ^ @since 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
        CInt
rd <- Ptr CInt -> Int -> IO CInt
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr CInt
fds Int
0
        CInt
wr <- Ptr CInt -> Int -> IO CInt
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr CInt
fds Int
1
        -- The write end must be non-blocking, since we may need to
        -- poke the event manager from a signal handler.
        CInt -> Bool -> IO ()
setNonBlockingFD CInt
wr Bool
True
        CInt -> IO ()
setCloseOnExec CInt
rd
        CInt -> IO ()
setCloseOnExec CInt
wr
        (CInt, CInt) -> IO (CInt, CInt)
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt
rd, CInt
wr)
  (CInt
ctrl_rd, CInt
ctrl_wr) <- IO (CInt, CInt)
createPipe
#if defined(HAVE_EVENTFD)
  CInt
ev <- String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1 String
"eventfd" (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> IO CInt
c_eventfd CInt
0 CInt
0
  CInt -> Bool -> IO ()
setNonBlockingFD CInt
ev Bool
True
  CInt -> IO ()
setCloseOnExec CInt
ev
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldRegister (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> IO ()
c_setIOManagerWakeupFd CInt
ev
#else
  (wake_rd, wake_wr) <- createPipe
  when shouldRegister $ c_setIOManagerWakeupFd wake_wr
#endif
  IORef Bool
isDead <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
  Control -> IO Control
forall (m :: * -> *) a. Monad m => a -> m a
return W :: Fd -> Fd -> Fd -> Bool -> IORef Bool -> Control
W { controlReadFd :: Fd
controlReadFd  = CInt -> Fd
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
ctrl_rd
           , controlWriteFd :: Fd
controlWriteFd = CInt -> Fd
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
ctrl_wr
#if defined(HAVE_EVENTFD)
           , controlEventFd :: Fd
controlEventFd = CInt -> Fd
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
ev
#else
           , wakeupReadFd   = fromIntegral wake_rd
           , wakeupWriteFd  = fromIntegral wake_wr
#endif
           , didRegisterWakeupFd :: Bool
didRegisterWakeupFd = Bool
shouldRegister
           , controlIsDead :: IORef Bool
controlIsDead  = IORef Bool
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
  Bool
_ <- IORef Bool -> Bool -> IO Bool
forall a. IORef a -> a -> IO a
atomicSwapIORef (Control -> IORef Bool
controlIsDead Control
w) Bool
True
  CInt
_ <- CInt -> IO CInt
c_close (CInt -> IO CInt) -> (Control -> CInt) -> Control -> IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fd -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Fd -> CInt) -> (Control -> Fd) -> Control -> CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Fd
controlReadFd (Control -> IO CInt) -> Control -> IO CInt
forall a b. (a -> b) -> a -> b
$ Control
w
  CInt
_ <- CInt -> IO CInt
c_close (CInt -> IO CInt) -> (Control -> CInt) -> Control -> IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fd -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Fd -> CInt) -> (Control -> Fd) -> Control -> CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Fd
controlWriteFd (Control -> IO CInt) -> Control -> IO CInt
forall a b. (a -> b) -> a -> b
$ Control
w
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Control -> Bool
didRegisterWakeupFd Control
w) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> IO ()
c_setIOManagerWakeupFd (-CInt
1)
#if defined(HAVE_EVENTFD)
  CInt
_ <- CInt -> IO CInt
c_close (CInt -> IO CInt) -> (Control -> CInt) -> Control -> IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fd -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Fd -> CInt) -> (Control -> Fd) -> Control -> CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Fd
controlEventFd (Control -> IO CInt) -> Control -> IO CInt
forall a b. (a -> b) -> a -> b
$ Control
w
#else
  _ <- c_close . fromIntegral . wakeupReadFd $ w
  _ <- c_close . fromIntegral . wakeupWriteFd $ w
#endif
  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
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

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 (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
            Word8
s <- Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek Ptr Word8
p
            case Word8
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 (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 (m :: * -> *) a. Monad m => a -> m a
return ControlMessage
CMsgDie
                Word8
_ -> do  -- Signal
                    ForeignPtr Word8
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)
                    ForeignPtr Word8
-> (Ptr Word8 -> IO ControlMessage) -> IO ControlMessage
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO ControlMessage) -> IO ControlMessage)
-> (Ptr Word8 -> IO ControlMessage) -> IO ControlMessage
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p_siginfo -> do
                        CSsize
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
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CSsize
r CSsize -> CSsize -> Bool
forall a. Eq a => a -> a -> Bool
/= CSize -> CSsize
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
sizeof_siginfo_t) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                            String -> IO ()
forall a. String -> a
errorWithoutStackTrace String
"failed to read siginfo_t"
                        let !s' :: CInt
s' = Word8 -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
s
                        ControlMessage -> IO ControlMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (ControlMessage -> IO ControlMessage)
-> ControlMessage -> IO ControlMessage
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> CInt -> ControlMessage
CMsgSignal ForeignPtr Word8
fp CInt
s'

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

sendWakeup :: Control -> IO ()
#if defined(HAVE_EVENTFD)
sendWakeup :: Control -> IO ()
sendWakeup Control
c = do
  CInt
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 CInt
n of
    CInt
0     -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    CInt
_     -> do Errno
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)
                Bool
isDead <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (Control -> IORef Bool
controlIsDead Control
c)
                if Bool
isDead Bool -> Bool -> Bool
&& Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eBADF
                  then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  else String -> IO ()
forall a. String -> IO a
throwErrno String
"sendWakeup"
#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 :: 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 (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

foreign import ccall unsafe "setIOManagerWakeupFd"
   c_setIOManagerWakeupFd :: CInt -> IO ()