{-# LINE 1 "libraries/base/GHC/Event/EPoll.hsc" #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE Trustworthy #-}
module GHC.Event.EPoll
(
new
, available
) where
import qualified GHC.Event.Internal as E
{-# LINE 37 "libraries/base/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, 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 <- forall a. Storable a => Int -> IO (Array a)
A.new Int
64
let !be :: Backend
be = 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)
forall (m :: * -> *) a. Monad m => a -> m a
return Backend
be
delete :: EPoll -> IO ()
delete :: EPoll -> IO ()
delete EPoll
be = do
CInt
_ <- CInt -> IO CInt
c_close forall b c a. (b -> c) -> (a -> b) -> a -> c
. EPollFd -> CInt
fromEPollFd forall b c a. (b -> c) -> (a -> b) -> a -> c
. EPoll -> EPollFd
epollFd forall a b. (a -> b) -> a -> b
$ EPoll
be
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 EPoll
ep Fd
fd Event
oevt Event
nevt =
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (EventType -> Fd -> Event
Event (Event -> EventType
fromEvent Event
nevt) Fd
fd) forall a b. (a -> b) -> a -> b
$ \Ptr Event
evptr -> do
EPollFd -> ControlOp -> Fd -> Ptr Event -> IO ()
epollControl (EPoll -> EPollFd
epollFd EPoll
ep) ControlOp
op Fd
fd Ptr Event
evptr
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
where op :: ControlOp
op | Event
oevt forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty = ControlOp
controlOpAdd
| Event
nevt forall a. Eq a => a -> a -> Bool
== 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 EPoll
ep Fd
fd Event
evt =
do let !ev :: EventType
ev = Event -> EventType
fromEvent Event
evt forall a. Bits a => a -> a -> a
.|. EventType
epollOneShot
CInt
res <- forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (EventType -> Fd -> Event
Event EventType
ev Fd
fd) 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 forall a. Eq a => a -> a -> Bool
== CInt
0
then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do Errno
err <- IO Errno
getErrno
if Errno
err forall a. Eq a => a -> a -> Bool
== Errno
eNOENT
then forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (EventType -> Fd -> Event
Event EventType
ev Fd
fd) forall a b. (a -> b) -> a -> b
$ \Ptr Event
evptr -> do
EPollFd -> ControlOp -> Fd -> Ptr Event -> IO ()
epollControl (EPoll -> EPollFd
epollFd EPoll
ep) ControlOp
controlOpAdd Fd
fd Ptr Event
evptr
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else forall a. String -> IO a
throwErrno String
"modifyFdOnce"
poll :: EPoll
-> Maybe Timeout
-> (Fd -> E.Event -> IO ())
-> IO Int
poll :: EPoll -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
poll EPoll
ep Maybe Timeout
mtimeout 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 <- forall a. Array a -> (Ptr a -> Int -> IO Int) -> IO Int
A.unsafeLoad Array Event
events forall a b. (a -> b) -> a -> b
$ \Ptr Event
es Int
cap -> case Maybe Timeout
mtimeout of
Just Timeout
timeout -> EPollFd -> Ptr Event -> Int -> Int -> IO Int
epollWait EPollFd
fd Ptr Event
es Int
cap forall a b. (a -> b) -> a -> b
$ Timeout -> Int
fromTimeout Timeout
timeout
Maybe Timeout
Nothing -> EPollFd -> Ptr Event -> Int -> IO Int
epollWaitNonBlock EPollFd
fd Ptr Event
es Int
cap
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ do
forall a. Storable a => Array a -> (a -> IO ()) -> IO ()
A.forM_ Array Event
events forall a b. (a -> b) -> a -> b
$ \Event
e -> Fd -> Event -> IO ()
f (Event -> Fd
eventFd Event
e) (EventType -> Event
toEvent (Event -> EventType
eventTypes Event
e))
Int
cap <- forall a. Array a -> IO Int
A.capacity Array Event
events
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
cap forall a. Eq a => a -> a -> Bool
== Int
n) forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Array a -> Int -> IO ()
A.ensureCapacity Array Event
events (Int
2 forall a. Num a => a -> a -> a
* Int
cap)
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
newtype EPollFd = EPollFd {
EPollFd -> CInt
fromEPollFd :: CInt
} deriving (EPollFd -> EPollFd -> Bool
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
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
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 Event
_ = (Int
16)
{-# LINE 140 "libraries/base/GHC/Event/EPoll.hsc" #-}
alignment _ = alignment (undefined :: CInt)
peek :: Ptr Event -> IO Event
peek Ptr Event
ptr = do
Word32
ets <- (\Ptr Event
hsc_ptr -> forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Event
hsc_ptr Int
0) Ptr Event
ptr
{-# LINE 144 "libraries/base/GHC/Event/EPoll.hsc" #-}
Fd
ed <- (\Ptr Event
hsc_ptr -> forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Event
hsc_ptr Int
8) Ptr Event
ptr
{-# LINE 145 "libraries/base/GHC/Event/EPoll.hsc" #-}
let !ev :: Event
ev = EventType -> Fd -> Event
Event (Word32 -> EventType
EventType Word32
ets) Fd
ed
forall (m :: * -> *) a. Monad m => a -> m a
return Event
ev
poke :: Ptr Event -> Event -> IO ()
poke Ptr Event
ptr Event
e = do
(\Ptr Event
hsc_ptr -> forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Event
hsc_ptr Int
0) Ptr Event
ptr (EventType -> Word32
unEventType forall a b. (a -> b) -> a -> b
$ Event -> EventType
eventTypes Event
e)
{-# LINE 150 "libraries/base/GHC/Event/EPoll.hsc" #-}
(\Ptr Event
hsc_ptr -> forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Event
hsc_ptr Int
8) Ptr Event
ptr (Event -> Fd
eventFd Event
e)
{-# LINE 151 "libraries/base/GHC/Event/EPoll.hsc" #-}
newtype ControlOp = ControlOp CInt
controlOpAdd :: ControlOp
controlOpAdd :: ControlOp
controlOpAdd = CInt -> ControlOp
ControlOp CInt
1
controlOpModify :: ControlOp
controlOpModify :: ControlOp
controlOpModify = CInt -> ControlOp
ControlOp CInt
3
controlOpDelete :: ControlOp
controlOpDelete :: ControlOp
controlOpDelete = CInt -> ControlOp
ControlOp CInt
2
{-# LINE 159 "libraries/base/GHC/Event/EPoll.hsc" #-}
newtype EventType = EventType {
unEventType :: Word32
} deriving ( Show
, Eq
, Num
, Bits
, FiniteBits
)
epollIn :: EventType
epollIn :: EventType
epollIn = Word32 -> EventType
EventType Word32
1
epollOut :: EventType
epollOut :: EventType
epollOut = Word32 -> EventType
EventType Word32
4
epollErr :: EventType
epollErr :: EventType
epollErr = Word32 -> EventType
EventType Word32
8
epollHup :: EventType
epollHup :: EventType
epollHup = Word32 -> EventType
EventType Word32
16
epollOneShot :: EventType
epollOneShot :: EventType
epollOneShot = Word32 -> EventType
EventType Word32
1073741824
{-# LINE 176 "libraries/base/GHC/Event/EPoll.hsc" #-}
epollCreate :: IO EPollFd
epollCreate :: IO EPollFd
epollCreate = do
CInt
fd <- forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1 String
"epollCreate" forall a b. (a -> b) -> a -> b
$
CInt -> IO CInt
c_epoll_create CInt
256
CInt -> IO ()
setCloseOnExec CInt
fd
let !epollFd' :: EPollFd
epollFd' = CInt -> EPollFd
EPollFd CInt
fd
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 EPollFd
epfd ControlOp
op Fd
fd Ptr Event
event =
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ String
"epollControl" 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 CInt
epfd) (ControlOp CInt
op) (Fd CInt
fd) 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 CInt
epfd) Ptr Event
events Int
numEvents Int
timeout =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. (Eq a, Num a) => String -> IO a -> IO a
E.throwErrnoIfMinus1NoRetry String
"epollWait" forall a b. (a -> b) -> a -> b
$
CInt -> Ptr Event -> CInt -> CInt -> IO CInt
c_epoll_wait CInt
epfd Ptr Event
events (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numEvents) (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 CInt
epfd) Ptr Event
events Int
numEvents =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. (Eq a, Num a) => String -> IO a -> IO a
E.throwErrnoIfMinus1NoRetry String
"epollWaitNonBlock" forall a b. (a -> b) -> a -> b
$
CInt -> Ptr Event -> CInt -> CInt -> IO CInt
c_epoll_wait_unsafe CInt
epfd Ptr Event
events (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numEvents) CInt
0
fromEvent :: E.Event -> EventType
fromEvent :: Event -> EventType
fromEvent Event
e = forall {p}. Num p => Event -> p -> p
remap Event
E.evtRead EventType
epollIn forall a. Bits a => a -> a -> a
.|.
forall {p}. Num p => Event -> p -> p
remap Event
E.evtWrite EventType
epollOut
where remap :: Event -> p -> p
remap Event
evt p
to
| Event
e Event -> Event -> Bool
`E.eventIs` Event
evt = p
to
| Bool
otherwise = p
0
toEvent :: EventType -> E.Event
toEvent :: EventType -> Event
toEvent EventType
e = forall {p}. Monoid p => EventType -> p -> p
remap (EventType
epollIn forall a. Bits a => a -> a -> a
.|. EventType
epollErr forall a. Bits a => a -> a -> a
.|. EventType
epollHup) Event
E.evtRead forall a. Monoid a => a -> a -> a
`mappend`
forall {p}. Monoid p => EventType -> p -> p
remap (EventType
epollOut forall a. Bits a => a -> a -> a
.|. EventType
epollErr forall a. Bits a => a -> a -> a
.|. EventType
epollHup) Event
E.evtWrite
where remap :: EventType -> p -> p
remap EventType
evt p
to
| EventType
e forall a. Bits a => a -> a -> a
.&. EventType
evt forall a. Eq a => a -> a -> Bool
/= EventType
0 = p
to
| Bool
otherwise = forall a. Monoid a => a
mempty
fromTimeout :: Timeout -> Int
fromTimeout :: Timeout -> Int
fromTimeout Timeout
Forever = -Int
1
fromTimeout (Timeout Word64
s) = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Word64
s forall {a}. Integral a => a -> a -> a
`divRoundUp` Word64
1000000
where
divRoundUp :: a -> a -> a
divRoundUp a
num a
denom = (a
num forall a. Num a => a -> a -> a
+ a
denom forall a. Num a => a -> a -> a
- a
1) 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 245 "libraries/base/GHC/Event/EPoll.hsc" #-}