{-# LINE 1 "GHC/Event/EPoll.hsc" #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE GeneralizedNewtypeDeriving
, NoImplicitPrelude
, BangPatterns
#-}
module GHC.Event.EPoll
(
new
, available
) where
import qualified GHC.Event.Internal as E
{-# LINE 38 "GHC/Event/EPoll.hsc" #-}
import Data.Bits (Bits, FiniteBits, (.|.), (.&.))
import Data.Word (Word32)
import Foreign.C.Error (eNOENT, getErrno, throwErrno,
throwErrnoIfMinus1, throwErrnoIfMinus1_)
import Foreign.C.Types (CInt(..))
import Foreign.Marshal.Utils (with)
import Foreign.Ptr (Ptr)
import Foreign.Storable (Storable(..))
import GHC.Base
import GHC.Num (Num(..))
import GHC.Real (fromIntegral, div)
import GHC.Show (Show)
import System.Posix.Internals (c_close)
import System.Posix.Internals (setCloseOnExec)
import System.Posix.Types (Fd(..))
import qualified GHC.Event.Array as A
import GHC.Event.Internal (Timeout(..))
available :: Bool
available :: Bool
available = Bool
True
{-# INLINE available #-}
data EPoll = EPoll {
EPoll -> EPollFd
epollFd :: {-# UNPACK #-} !EPollFd
, EPoll -> Array Event
epollEvents :: {-# UNPACK #-} !(A.Array Event)
}
new :: IO E.Backend
new :: IO Backend
new = do
EPollFd
epfd <- IO EPollFd
epollCreate
Array Event
evts <- Int -> IO (Array Event)
forall a. Storable a => Int -> IO (Array a)
A.new 64
let !be :: Backend
be = (EPoll -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int)
-> (EPoll -> Fd -> Event -> Event -> IO Bool)
-> (EPoll -> Fd -> Event -> IO Bool)
-> (EPoll -> IO ())
-> EPoll
-> Backend
forall a.
(a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int)
-> (a -> Fd -> Event -> Event -> IO Bool)
-> (a -> Fd -> Event -> IO Bool)
-> (a -> IO ())
-> a
-> Backend
E.backend EPoll -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
poll EPoll -> Fd -> Event -> Event -> IO Bool
modifyFd EPoll -> Fd -> Event -> IO Bool
modifyFdOnce EPoll -> IO ()
delete (EPollFd -> Array Event -> EPoll
EPoll EPollFd
epfd Array Event
evts)
Backend -> IO Backend
forall (m :: * -> *) a. Monad m => a -> m a
return Backend
be
delete :: EPoll -> IO ()
delete :: EPoll -> IO ()
delete be :: EPoll
be = do
CInt
_ <- CInt -> IO CInt
c_close (CInt -> IO CInt) -> (EPoll -> CInt) -> EPoll -> IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EPollFd -> CInt
fromEPollFd (EPollFd -> CInt) -> (EPoll -> EPollFd) -> EPoll -> CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EPoll -> EPollFd
epollFd (EPoll -> IO CInt) -> EPoll -> IO CInt
forall a b. (a -> b) -> a -> b
$ EPoll
be
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
modifyFd :: EPoll -> Fd -> E.Event -> E.Event -> IO Bool
modifyFd :: EPoll -> Fd -> Event -> Event -> IO Bool
modifyFd ep :: EPoll
ep fd :: Fd
fd oevt :: Event
oevt nevt :: Event
nevt =
Event -> (Ptr Event -> IO Bool) -> IO Bool
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (EventType -> Fd -> Event
Event (Event -> EventType
fromEvent Event
nevt) Fd
fd) ((Ptr Event -> IO Bool) -> IO Bool)
-> (Ptr Event -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \evptr :: Ptr Event
evptr -> do
EPollFd -> ControlOp -> Fd -> Ptr Event -> IO ()
epollControl (EPoll -> EPollFd
epollFd EPoll
ep) ControlOp
op Fd
fd Ptr Event
evptr
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
where op :: ControlOp
op | Event
oevt Event -> Event -> Bool
forall a. Eq a => a -> a -> Bool
== Event
forall a. Monoid a => a
mempty = ControlOp
controlOpAdd
| Event
nevt Event -> Event -> Bool
forall a. Eq a => a -> a -> Bool
== Event
forall a. Monoid a => a
mempty = ControlOp
controlOpDelete
| Bool
otherwise = ControlOp
controlOpModify
modifyFdOnce :: EPoll -> Fd -> E.Event -> IO Bool
modifyFdOnce :: EPoll -> Fd -> Event -> IO Bool
modifyFdOnce ep :: EPoll
ep fd :: Fd
fd evt :: Event
evt =
do let !ev :: EventType
ev = Event -> EventType
fromEvent Event
evt EventType -> EventType -> EventType
forall a. Bits a => a -> a -> a
.|. EventType
epollOneShot
CInt
res <- Event -> (Ptr Event -> IO CInt) -> IO CInt
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (EventType -> Fd -> Event
Event EventType
ev Fd
fd) ((Ptr Event -> IO CInt) -> IO CInt)
-> (Ptr Event -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$
EPollFd -> ControlOp -> Fd -> Ptr Event -> IO CInt
epollControl_ (EPoll -> EPollFd
epollFd EPoll
ep) ControlOp
controlOpModify Fd
fd
if CInt
res CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== 0
then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do Errno
err <- IO Errno
getErrno
if Errno
err Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eNOENT
then Event -> (Ptr Event -> IO Bool) -> IO Bool
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (EventType -> Fd -> Event
Event EventType
ev Fd
fd) ((Ptr Event -> IO Bool) -> IO Bool)
-> (Ptr Event -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \evptr :: Ptr Event
evptr -> do
EPollFd -> ControlOp -> Fd -> Ptr Event -> IO ()
epollControl (EPoll -> EPollFd
epollFd EPoll
ep) ControlOp
controlOpAdd Fd
fd Ptr Event
evptr
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else String -> IO Bool
forall a. String -> IO a
throwErrno "modifyFdOnce"
poll :: EPoll
-> Maybe Timeout
-> (Fd -> E.Event -> IO ())
-> IO Int
poll :: EPoll -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
poll ep :: EPoll
ep mtimeout :: Maybe Timeout
mtimeout f :: Fd -> Event -> IO ()
f = do
let events :: Array Event
events = EPoll -> Array Event
epollEvents EPoll
ep
fd :: EPollFd
fd = EPoll -> EPollFd
epollFd EPoll
ep
Int
n <- Array Event -> (Ptr Event -> Int -> IO Int) -> IO Int
forall a. Array a -> (Ptr a -> Int -> IO Int) -> IO Int
A.unsafeLoad Array Event
events ((Ptr Event -> Int -> IO Int) -> IO Int)
-> (Ptr Event -> Int -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \es :: Ptr Event
es cap :: Int
cap -> case Maybe Timeout
mtimeout of
Just timeout :: Timeout
timeout -> EPollFd -> Ptr Event -> Int -> Int -> IO Int
epollWait EPollFd
fd Ptr Event
es Int
cap (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Timeout -> Int
fromTimeout Timeout
timeout
Nothing -> EPollFd -> Ptr Event -> Int -> IO Int
epollWaitNonBlock EPollFd
fd Ptr Event
es Int
cap
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Array Event -> (Event -> IO ()) -> IO ()
forall a. Storable a => Array a -> (a -> IO ()) -> IO ()
A.forM_ Array Event
events ((Event -> IO ()) -> IO ()) -> (Event -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \e :: Event
e -> Fd -> Event -> IO ()
f (Event -> Fd
eventFd Event
e) (EventType -> Event
toEvent (Event -> EventType
eventTypes Event
e))
Int
cap <- Array Event -> IO Int
forall a. Array a -> IO Int
A.capacity Array Event
events
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
cap Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Array Event -> Int -> IO ()
forall a. Storable a => Array a -> Int -> IO ()
A.ensureCapacity Array Event
events (2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
cap)
Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
newtype EPollFd = EPollFd {
EPollFd -> CInt
fromEPollFd :: CInt
} deriving (EPollFd -> EPollFd -> Bool
(EPollFd -> EPollFd -> Bool)
-> (EPollFd -> EPollFd -> Bool) -> Eq EPollFd
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EPollFd -> EPollFd -> Bool
$c/= :: EPollFd -> EPollFd -> Bool
== :: EPollFd -> EPollFd -> Bool
$c== :: EPollFd -> EPollFd -> Bool
Eq, Int -> EPollFd -> ShowS
[EPollFd] -> ShowS
EPollFd -> String
(Int -> EPollFd -> ShowS)
-> (EPollFd -> String) -> ([EPollFd] -> ShowS) -> Show EPollFd
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EPollFd] -> ShowS
$cshowList :: [EPollFd] -> ShowS
show :: EPollFd -> String
$cshow :: EPollFd -> String
showsPrec :: Int -> EPollFd -> ShowS
$cshowsPrec :: Int -> EPollFd -> ShowS
Show)
data Event = Event {
Event -> EventType
eventTypes :: EventType
, Event -> Fd
eventFd :: Fd
} deriving (Int -> Event -> ShowS
[Event] -> ShowS
Event -> String
(Int -> Event -> ShowS)
-> (Event -> String) -> ([Event] -> ShowS) -> Show Event
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Event] -> ShowS
$cshowList :: [Event] -> ShowS
show :: Event -> String
$cshow :: Event -> String
showsPrec :: Int -> Event -> ShowS
$cshowsPrec :: Int -> Event -> ShowS
Show)
instance Storable Event where
sizeOf :: Event -> Int
sizeOf _ = (12)
{-# LINE 142 "GHC/Event/EPoll.hsc" #-}
alignment _ = alignment (undefined :: CInt)
peek :: Ptr Event -> IO Event
peek ptr :: Ptr Event
ptr = do
Word32
ets <- (\hsc_ptr :: Ptr Event
hsc_ptr -> Ptr Event -> Int -> IO Word32
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Event
hsc_ptr 0) Ptr Event
ptr
{-# LINE 146 "GHC/Event/EPoll.hsc" #-}
Fd
ed <- (\hsc_ptr :: Ptr Event
hsc_ptr -> Ptr Event -> Int -> IO Fd
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Event
hsc_ptr 4) Ptr Event
ptr
{-# LINE 147 "GHC/Event/EPoll.hsc" #-}
let !ev :: Event
ev = EventType -> Fd -> Event
Event (Word32 -> EventType
EventType Word32
ets) Fd
ed
Event -> IO Event
forall (m :: * -> *) a. Monad m => a -> m a
return Event
ev
poke :: Ptr Event -> Event -> IO ()
poke ptr :: Ptr Event
ptr e :: Event
e = do
(\hsc_ptr :: Ptr Event
hsc_ptr -> Ptr Event -> Int -> Word32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Event
hsc_ptr 0) Ptr Event
ptr (EventType -> Word32
unEventType (EventType -> Word32) -> EventType -> Word32
forall a b. (a -> b) -> a -> b
$ Event -> EventType
eventTypes Event
e)
{-# LINE 152 "GHC/Event/EPoll.hsc" #-}
(\hsc_ptr :: Ptr Event
hsc_ptr -> Ptr Event -> Int -> Fd -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Event
hsc_ptr 4) Ptr Event
ptr (Event -> Fd
eventFd Event
e)
{-# LINE 153 "GHC/Event/EPoll.hsc" #-}
newtype ControlOp = ControlOp CInt
controlOpAdd :: ControlOp
controlOpAdd :: ControlOp
controlOpAdd = CInt -> ControlOp
ControlOp 1
controlOpModify :: ControlOp
controlOpModify :: ControlOp
controlOpModify = CInt -> ControlOp
ControlOp 3
controlOpDelete :: ControlOp
controlOpDelete :: ControlOp
controlOpDelete = CInt -> ControlOp
ControlOp 2
{-# LINE 161 "GHC/Event/EPoll.hsc" #-}
newtype EventType = EventType {
unEventType :: Word32
} deriving ( Show
, Eq
, Num
, Bits
, FiniteBits
)
epollIn :: EventType
epollIn :: EventType
epollIn = Word32 -> EventType
EventType 1
epollOut :: EventType
epollOut :: EventType
epollOut = Word32 -> EventType
EventType 4
epollErr :: EventType
epollErr :: EventType
epollErr = Word32 -> EventType
EventType 8
epollHup :: EventType
epollHup :: EventType
epollHup = Word32 -> EventType
EventType 16
epollOneShot :: EventType
epollOneShot :: EventType
epollOneShot = Word32 -> EventType
EventType 1073741824
{-# LINE 178 "GHC/Event/EPoll.hsc" #-}
epollCreate :: IO EPollFd
epollCreate :: IO EPollFd
epollCreate = do
CInt
fd <- String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1 "epollCreate" (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$
CInt -> IO CInt
c_epoll_create 256
CInt -> IO ()
setCloseOnExec CInt
fd
let !epollFd' :: EPollFd
epollFd' = CInt -> EPollFd
EPollFd CInt
fd
EPollFd -> IO EPollFd
forall (m :: * -> *) a. Monad m => a -> m a
return EPollFd
epollFd'
epollControl :: EPollFd -> ControlOp -> Fd -> Ptr Event -> IO ()
epollControl :: EPollFd -> ControlOp -> Fd -> Ptr Event -> IO ()
epollControl epfd :: EPollFd
epfd op :: ControlOp
op fd :: Fd
fd event :: Ptr Event
event =
String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ "epollControl" (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ EPollFd -> ControlOp -> Fd -> Ptr Event -> IO CInt
epollControl_ EPollFd
epfd ControlOp
op Fd
fd Ptr Event
event
epollControl_ :: EPollFd -> ControlOp -> Fd -> Ptr Event -> IO CInt
epollControl_ :: EPollFd -> ControlOp -> Fd -> Ptr Event -> IO CInt
epollControl_ (EPollFd epfd :: CInt
epfd) (ControlOp op :: CInt
op) (Fd fd :: CInt
fd) event :: Ptr Event
event =
CInt -> CInt -> CInt -> Ptr Event -> IO CInt
c_epoll_ctl CInt
epfd CInt
op CInt
fd Ptr Event
event
epollWait :: EPollFd -> Ptr Event -> Int -> Int -> IO Int
epollWait :: EPollFd -> Ptr Event -> Int -> Int -> IO Int
epollWait (EPollFd epfd :: CInt
epfd) events :: Ptr Event
events numEvents :: Int
numEvents timeout :: Int
timeout =
(CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IO CInt -> IO Int) -> (IO CInt -> IO CInt) -> IO CInt -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
E.throwErrnoIfMinus1NoRetry "epollWait" (IO CInt -> IO Int) -> IO CInt -> IO Int
forall a b. (a -> b) -> a -> b
$
CInt -> Ptr Event -> CInt -> CInt -> IO CInt
c_epoll_wait CInt
epfd Ptr Event
events (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numEvents) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
timeout)
epollWaitNonBlock :: EPollFd -> Ptr Event -> Int -> IO Int
epollWaitNonBlock :: EPollFd -> Ptr Event -> Int -> IO Int
epollWaitNonBlock (EPollFd epfd :: CInt
epfd) events :: Ptr Event
events numEvents :: Int
numEvents =
(CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IO CInt -> IO Int) -> (IO CInt -> IO CInt) -> IO CInt -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
E.throwErrnoIfMinus1NoRetry "epollWaitNonBlock" (IO CInt -> IO Int) -> IO CInt -> IO Int
forall a b. (a -> b) -> a -> b
$
CInt -> Ptr Event -> CInt -> CInt -> IO CInt
c_epoll_wait_unsafe CInt
epfd Ptr Event
events (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numEvents) 0
fromEvent :: E.Event -> EventType
fromEvent :: Event -> EventType
fromEvent e :: Event
e = Event -> EventType -> EventType
forall p. Num p => Event -> p -> p
remap Event
E.evtRead EventType
epollIn EventType -> EventType -> EventType
forall a. Bits a => a -> a -> a
.|.
Event -> EventType -> EventType
forall p. Num p => Event -> p -> p
remap Event
E.evtWrite EventType
epollOut
where remap :: Event -> p -> p
remap evt :: Event
evt to :: p
to
| Event
e Event -> Event -> Bool
`E.eventIs` Event
evt = p
to
| Bool
otherwise = 0
toEvent :: EventType -> E.Event
toEvent :: EventType -> Event
toEvent e :: EventType
e = EventType -> Event -> Event
forall p. Monoid p => EventType -> p -> p
remap (EventType
epollIn EventType -> EventType -> EventType
forall a. Bits a => a -> a -> a
.|. EventType
epollErr EventType -> EventType -> EventType
forall a. Bits a => a -> a -> a
.|. EventType
epollHup) Event
E.evtRead Event -> Event -> Event
forall a. Monoid a => a -> a -> a
`mappend`
EventType -> Event -> Event
forall p. Monoid p => EventType -> p -> p
remap (EventType
epollOut EventType -> EventType -> EventType
forall a. Bits a => a -> a -> a
.|. EventType
epollErr EventType -> EventType -> EventType
forall a. Bits a => a -> a -> a
.|. EventType
epollHup) Event
E.evtWrite
where remap :: EventType -> p -> p
remap evt :: EventType
evt to :: p
to
| EventType
e EventType -> EventType -> EventType
forall a. Bits a => a -> a -> a
.&. EventType
evt EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 = p
to
| Bool
otherwise = p
forall a. Monoid a => a
mempty
fromTimeout :: Timeout -> Int
fromTimeout :: Timeout -> Int
fromTimeout Forever = -1
fromTimeout (Timeout s :: Word64
s) = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ Word64
s Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`divRoundUp` 1000000
where
divRoundUp :: a -> a -> a
divRoundUp num :: a
num denom :: a
denom = (a
num a -> a -> a
forall a. Num a => a -> a -> a
+ a
denom a -> a -> a
forall a. Num a => a -> a -> a
- 1) a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
denom
foreign import ccall unsafe "sys/epoll.h epoll_create"
c_epoll_create :: CInt -> IO CInt
foreign import ccall unsafe "sys/epoll.h epoll_ctl"
c_epoll_ctl :: CInt -> CInt -> CInt -> Ptr Event -> IO CInt
foreign import ccall safe "sys/epoll.h epoll_wait"
c_epoll_wait :: CInt -> Ptr Event -> CInt -> CInt -> IO CInt
foreign import ccall unsafe "sys/epoll.h epoll_wait"
c_epoll_wait_unsafe :: CInt -> Ptr Event -> CInt -> CInt -> IO CInt
{-# LINE 247 "GHC/Event/EPoll.hsc" #-}