{-# 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 <- Int -> IO (Array Event)
forall a. Storable a => Int -> IO (Array a)
A.new Int
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 a. a -> IO a
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 (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 a. a -> IO a
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 =
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
$ \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 a. a -> IO a
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 EPoll
ep Fd
fd 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
== CInt
0
then Bool -> IO Bool
forall a. a -> IO a
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
$ \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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else String -> IO Bool
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 <- 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
$ \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 (Int -> IO Int) -> Int -> IO Int
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
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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
$ \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 (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
cap)
Int -> IO Int
forall a. a -> IO a
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
$c== :: EPollFd -> EPollFd -> Bool
== :: EPollFd -> EPollFd -> Bool
$c/= :: EPollFd -> EPollFd -> Bool
/= :: 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
$cshowsPrec :: Int -> EPollFd -> ShowS
showsPrec :: Int -> EPollFd -> ShowS
$cshow :: EPollFd -> String
show :: EPollFd -> String
$cshowList :: [EPollFd] -> ShowS
showList :: [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
$cshowsPrec :: Int -> Event -> ShowS
showsPrec :: Int -> Event -> ShowS
$cshow :: Event -> String
show :: Event -> String
$cshowList :: [Event] -> ShowS
showList :: [Event] -> ShowS
Show)
instance Storable Event where
sizeOf :: Event -> Int
sizeOf Event
_ = (Int
12)
{-# 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 -> Ptr Event -> Int -> IO Word32
forall b. Ptr b -> Int -> IO Word32
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 -> Ptr Event -> Int -> IO Fd
forall b. Ptr b -> Int -> IO Fd
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Event
hsc_ptr Int
4) 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
Event -> IO Event
forall a. a -> IO a
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 -> Ptr Event -> Int -> Word32 -> IO ()
forall b. Ptr b -> Int -> Word32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Event
hsc_ptr Int
0) Ptr Event
ptr (EventType -> Word32
unEventType (EventType -> Word32) -> EventType -> Word32
forall a b. (a -> b) -> a -> b
$ Event -> EventType
eventTypes Event
e)
{-# LINE 150 "libraries/base/GHC/Event/EPoll.hsc" #-}
(\Ptr Event
hsc_ptr -> Ptr Event -> Int -> Fd -> IO ()
forall b. Ptr b -> Int -> Fd -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Event
hsc_ptr Int
4) 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 <- String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1 String
"epollCreate" (IO CInt -> IO CInt) -> IO CInt -> IO CInt
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
EPollFd -> IO EPollFd
forall a. a -> IO a
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 =
String -> IO CInt -> IO ()
forall a. (Eq a, Num a) => String -> IO a -> IO ()
throwErrnoIfMinus1_ String
"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 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 =
(CInt -> Int) -> IO CInt -> 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 -> 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 String
"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 CInt
epfd) Ptr Event
events Int
numEvents =
(CInt -> Int) -> IO CInt -> 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 -> 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 String
"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) CInt
0
fromEvent :: E.Event -> EventType
fromEvent :: Event -> EventType
fromEvent 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 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 = 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 EventType
evt 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
/= EventType
0 = p
to
| Bool
otherwise = p
forall a. Monoid a => a
mempty
fromTimeout :: Timeout -> Int
fromTimeout :: Timeout -> Int
fromTimeout Timeout
Forever = -Int
1
fromTimeout (Timeout 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` Word64
1000000
where
divRoundUp :: a -> a -> a
divRoundUp a
num 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
- 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 245 "libraries/base/GHC/Event/EPoll.hsc" #-}