{-# 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
(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
, 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
)
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 = 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
CInt -> Bool -> IO ()
setNonBlockingFD CInt
wr Bool
True
CInt -> IO ()
setCloseOnExec CInt
rd
CInt -> IO ()
setCloseOnExec CInt
wr
(CInt, CInt) -> IO (CInt, CInt)
forall a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return 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
}
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 a. a -> IO a
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 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
Word8
s <- Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek Ptr Word8
p
case Word8
s of
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
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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
CInt
_ -> do Errno
errno <- IO Errno
getErrno
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 a. a -> IO a
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 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
foreign import ccall unsafe "setIOManagerWakeupFd"
c_setIOManagerWakeupFd :: CInt -> IO ()