{-# LINE 1 "libraries/base/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 "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)
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 = True
{-# INLINE available #-}
data EPoll = EPoll {
epollFd :: {-# UNPACK #-} !EPollFd
, epollEvents :: {-# UNPACK #-} !(A.Array Event)
}
new :: IO E.Backend
new = do
epfd <- epollCreate
evts <- A.new 64
let !be = E.backend poll modifyFd modifyFdOnce delete (EPoll epfd evts)
return be
delete :: EPoll -> IO ()
delete be = do
_ <- c_close . fromEPollFd . epollFd $ be
return ()
modifyFd :: EPoll -> Fd -> E.Event -> E.Event -> IO Bool
modifyFd ep fd oevt nevt =
with (Event (fromEvent nevt) fd) $ \evptr -> do
epollControl (epollFd ep) op fd evptr
return True
where op | oevt == mempty = controlOpAdd
| nevt == mempty = controlOpDelete
| otherwise = controlOpModify
modifyFdOnce :: EPoll -> Fd -> E.Event -> IO Bool
modifyFdOnce ep fd evt =
do let !ev = fromEvent evt .|. epollOneShot
res <- with (Event ev fd) $
epollControl_ (epollFd ep) controlOpModify fd
if res == 0
then return True
else do err <- getErrno
if err == eNOENT
then with (Event ev fd) $ \evptr -> do
epollControl (epollFd ep) controlOpAdd fd evptr
return True
else throwErrno "modifyFdOnce"
poll :: EPoll
-> Maybe Timeout
-> (Fd -> E.Event -> IO ())
-> IO Int
poll ep mtimeout f = do
let events = epollEvents ep
fd = epollFd ep
n <- A.unsafeLoad events $ \es cap -> case mtimeout of
Just timeout -> epollWait fd es cap $ fromTimeout timeout
Nothing -> epollWaitNonBlock fd es cap
when (n > 0) $ do
A.forM_ events $ \e -> f (eventFd e) (toEvent (eventTypes e))
cap <- A.capacity events
when (cap == n) $ A.ensureCapacity events (2 * cap)
return n
newtype EPollFd = EPollFd {
fromEPollFd :: CInt
} deriving (Eq, Show)
data Event = Event {
eventTypes :: EventType
, eventFd :: Fd
} deriving (Show)
instance Storable Event where
sizeOf _ = (12)
{-# LINE 142 "libraries/base/GHC/Event/EPoll.hsc" #-}
alignment _ = alignment (undefined :: CInt)
peek ptr = do
ets <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
{-# LINE 146 "libraries/base/GHC/Event/EPoll.hsc" #-}
ed <- (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr
{-# LINE 147 "libraries/base/GHC/Event/EPoll.hsc" #-}
let !ev = Event (EventType ets) ed
return ev
poke ptr e = do
(\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr (unEventType $ eventTypes e)
{-# LINE 152 "libraries/base/GHC/Event/EPoll.hsc" #-}
(\hsc_ptr -> pokeByteOff hsc_ptr 4) ptr (eventFd e)
{-# LINE 153 "libraries/base/GHC/Event/EPoll.hsc" #-}
newtype ControlOp = ControlOp CInt
controlOpAdd :: ControlOp
controlOpAdd = ControlOp 1
controlOpModify :: ControlOp
controlOpModify = ControlOp 3
controlOpDelete :: ControlOp
controlOpDelete = ControlOp 2
{-# LINE 161 "libraries/base/GHC/Event/EPoll.hsc" #-}
newtype EventType = EventType {
unEventType :: Word32
} deriving (Show, Eq, Num, Bits, FiniteBits)
epollIn :: EventType
epollIn = EventType 1
epollOut :: EventType
epollOut = EventType 4
epollErr :: EventType
epollErr = EventType 8
epollHup :: EventType
epollHup = EventType 16
epollOneShot :: EventType
epollOneShot = EventType 1073741824
{-# LINE 173 "libraries/base/GHC/Event/EPoll.hsc" #-}
epollCreate :: IO EPollFd
epollCreate = do
fd <- throwErrnoIfMinus1 "epollCreate" $
c_epoll_create 256
setCloseOnExec fd
let !epollFd' = EPollFd fd
return epollFd'
epollControl :: EPollFd -> ControlOp -> Fd -> Ptr Event -> IO ()
epollControl epfd op fd event =
throwErrnoIfMinus1_ "epollControl" $ epollControl_ epfd op fd event
epollControl_ :: EPollFd -> ControlOp -> Fd -> Ptr Event -> IO CInt
epollControl_ (EPollFd epfd) (ControlOp op) (Fd fd) event =
c_epoll_ctl epfd op fd event
epollWait :: EPollFd -> Ptr Event -> Int -> Int -> IO Int
epollWait (EPollFd epfd) events numEvents timeout =
fmap fromIntegral .
E.throwErrnoIfMinus1NoRetry "epollWait" $
c_epoll_wait epfd events (fromIntegral numEvents) (fromIntegral timeout)
epollWaitNonBlock :: EPollFd -> Ptr Event -> Int -> IO Int
epollWaitNonBlock (EPollFd epfd) events numEvents =
fmap fromIntegral .
E.throwErrnoIfMinus1NoRetry "epollWaitNonBlock" $
c_epoll_wait_unsafe epfd events (fromIntegral numEvents) 0
fromEvent :: E.Event -> EventType
fromEvent e = remap E.evtRead epollIn .|.
remap E.evtWrite epollOut
where remap evt to
| e `E.eventIs` evt = to
| otherwise = 0
toEvent :: EventType -> E.Event
toEvent e = remap (epollIn .|. epollErr .|. epollHup) E.evtRead `mappend`
remap (epollOut .|. epollErr .|. epollHup) E.evtWrite
where remap evt to
| e .&. evt /= 0 = to
| otherwise = mempty
fromTimeout :: Timeout -> Int
fromTimeout Forever = -1
fromTimeout (Timeout s) = fromIntegral $ s `divRoundUp` 1000000
where
divRoundUp num denom = (num + denom - 1) `div` 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 242 "libraries/base/GHC/Event/EPoll.hsc" #-}