{-# LANGUAGE Unsafe #-}
{-# LANGUAGE CPP
, NoImplicitPrelude
, ScopedTypeVariables
, BangPatterns
#-}
module GHC.Event.Control
(
Signal
, ControlMessage(..)
, Control
, newControl
, closeControl
, readControlMessage
, controlReadFd
, controlWriteFd
, wakeupReadFd
, sendWakeup
, sendDie
, setNonBlockingFD
) where
#include "EventConfig.h"
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 (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 ( ControlMessage -> ControlMessage -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ControlMessage -> ControlMessage -> Bool
$c/= :: ControlMessage -> ControlMessage -> Bool
== :: ControlMessage -> ControlMessage -> Bool
$c== :: ControlMessage -> ControlMessage -> Bool
Eq
, Int -> ControlMessage -> ShowS
[ControlMessage] -> ShowS
ControlMessage -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ControlMessage] -> ShowS
$cshowList :: [ControlMessage] -> ShowS
show :: ControlMessage -> String
$cshow :: ControlMessage -> String
showsPrec :: Int -> ControlMessage -> ShowS
$cshowsPrec :: Int -> ControlMessage -> ShowS
Show
)
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
, Control -> IORef Bool
controlIsDead :: !(IORef Bool)
}
#if defined(HAVE_EVENTFD)
wakeupReadFd :: Control -> Fd
wakeupReadFd :: Control -> Fd
wakeupReadFd = Control -> Fd
controlEventFd
{-# INLINE wakeupReadFd #-}
#endif
newControl :: Bool -> IO Control
newControl :: Bool -> IO Control
newControl Bool
shouldRegister = forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
2 forall a b. (a -> b) -> a -> b
$ \Ptr CInt
fds -> do
let createPipe :: IO (CInt, CInt)
createPipe = do
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ String
"pipe" forall a b. (a -> b) -> a -> b
$ Ptr CInt -> IO CInt
c_pipe Ptr CInt
fds
CInt
rd <- forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr CInt
fds Int
0
CInt
wr <- forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr CInt
fds Int
1
CInt -> Bool -> IO ()
setNonBlockingFD CInt
wr Bool
True
CInt -> IO ()
setCloseOnExec CInt
rd
CInt -> IO ()
setCloseOnExec CInt
wr
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 <- forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1 String
"eventfd" 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldRegister 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 <- forall a. a -> IO (IORef a)
newIORef Bool
False
forall (m :: * -> *) a. Monad m => a -> m a
return W { controlReadFd :: Fd
controlReadFd = forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
ctrl_rd
, controlWriteFd :: Fd
controlWriteFd = forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
ctrl_wr
#if defined(HAVE_EVENTFD)
, controlEventFd :: Fd
controlEventFd = 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
}
closeControl :: Control -> IO ()
closeControl :: Control -> IO ()
closeControl Control
w = do
Bool
_ <- forall a. IORef a -> a -> IO a
atomicSwapIORef (Control -> IORef Bool
controlIsDead Control
w) Bool
True
CInt
_ <- CInt -> IO CInt
c_close forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Fd
controlReadFd forall a b. (a -> b) -> a -> b
$ Control
w
CInt
_ <- CInt -> IO CInt
c_close forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Fd
controlWriteFd forall a b. (a -> b) -> a -> b
$ Control
w
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Control -> Bool
didRegisterWakeupFd Control
w) forall a b. (a -> b) -> a -> b
$ CInt -> IO ()
c_setIOManagerWakeupFd (-CInt
1)
#if defined(HAVE_EVENTFD)
CInt
_ <- CInt -> IO CInt
c_close forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Fd
controlEventFd forall a b. (a -> b) -> a -> b
$ Control
w
#else
_ <- c_close . fromIntegral . wakeupReadFd $ w
_ <- c_close . fromIntegral . wakeupWriteFd $ w
#endif
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 forall a. Eq a => a -> a -> Bool
== Control -> Fd
wakeupReadFd Control
ctrl = forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
wakeupBufferSize forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> do
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ String
"readWakeupMessage" forall a b. (a -> b) -> a -> b
$
CInt -> Ptr Word8 -> CSize -> IO CSsize
c_read (forall a b. (Integral a, Num b) => a -> b
fromIntegral Fd
fd) Ptr Word8
p (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
wakeupBufferSize)
forall (m :: * -> *) a. Monad m => a -> m a
return ControlMessage
CMsgWakeup
| Bool
otherwise =
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> do
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ String
"readControlMessage" forall a b. (a -> b) -> a -> b
$
CInt -> Ptr Word8 -> CSize -> IO CSsize
c_read (forall a b. (Integral a, Num b) => a -> b
fromIntegral Fd
fd) Ptr Word8
p CSize
1
Word8
s <- forall a. Storable a => Ptr a -> IO a
peek Ptr Word8
p
case Word8
s of
Word8
_ | Word8
s forall a. Eq a => a -> a -> Bool
== Word8
io_MANAGER_WAKEUP -> forall (m :: * -> *) a. Monad m => a -> m a
return ControlMessage
CMsgWakeup
Word8
_ | Word8
s forall a. Eq a => a -> a -> Bool
== Word8
io_MANAGER_DIE -> forall (m :: * -> *) a. Monad m => a -> m a
return ControlMessage
CMsgDie
Word8
_ -> do
ForeignPtr Word8
fp <- forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes (forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
sizeof_siginfo_t)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p_siginfo -> do
CSsize
r <- CInt -> Ptr Word8 -> CSize -> IO CSsize
c_read (forall a b. (Integral a, Num b) => a -> b
fromIntegral Fd
fd) (forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
p_siginfo)
CSize
sizeof_siginfo_t
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CSsize
r forall a. Eq a => a -> a -> Bool
/= forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
sizeof_siginfo_t) forall a b. (a -> b) -> a -> b
$
forall a. String -> a
errorWithoutStackTrace String
"failed to read siginfo_t"
let !s' :: CInt
s' = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
s
forall (m :: * -> *) a. Monad m => a -> m a
return 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Control -> Fd
controlEventFd Control
c)) CULLong
1
case CInt
n of
CInt
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
CInt
_ -> do Errno
errno <- IO Errno
getErrno
Bool
isDead <- forall a. IORef a -> IO a
readIORef (Control -> IORef Bool
controlIsDead Control
c)
if Bool
isDead Bool -> Bool -> Bool
&& Errno
errno forall a. Eq a => a -> a -> Bool
== Errno
eBADF
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else 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 = forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ String
"sendDie" 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 = forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> do
case ControlMessage
msg of
ControlMessage
CMsgWakeup -> forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
p Word8
io_MANAGER_WAKEUP
ControlMessage
CMsgDie -> forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
p Word8
io_MANAGER_DIE
CMsgSignal ForeignPtr Word8
_fp CInt
_s -> forall a. String -> a
errorWithoutStackTrace String
"Signals can only be sent from within the RTS"
forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CInt -> Ptr Word8 -> CSize -> IO CSsize
c_write (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 ()