{-# LINE 1 "libraries/ghc-internal/src/GHC/Internal/Event/EPoll.hsc" #-}
{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE Trustworthy                #-}

-----------------------------------------------------------------------------
-- |
-- A binding to the epoll I/O event notification facility
--
-- epoll is a variant of poll that can be used either as an edge-triggered or
-- a level-triggered interface and scales well to large numbers of watched file
-- descriptors.
--
-- epoll decouples monitor an fd from the process of registering it.
--
-----------------------------------------------------------------------------

module GHC.Internal.Event.EPoll
    (
      new
    , available
    ) where

import qualified GHC.Internal.Event.Internal as E



{-# LINE 37 "libraries/ghc-internal/src/GHC/Internal/Event/EPoll.hsc" #-}



import GHC.Internal.Data.Bits (Bits, FiniteBits, (.|.), (.&.))
import GHC.Internal.Word (Word32)
import GHC.Internal.Foreign.C.Error (eNOENT, getErrno, throwErrno,
                        throwErrnoIfMinus1, throwErrnoIfMinus1_)
import GHC.Internal.Foreign.C.Types (CInt(..))
import GHC.Internal.Foreign.Marshal.Utils (with)
import GHC.Internal.Foreign.Ptr (Ptr)
import GHC.Internal.Foreign.Storable (Storable(..))
import GHC.Internal.Base
import GHC.Internal.Num (Num(..))
import GHC.Internal.Real (fromIntegral, div)
import GHC.Internal.Show (Show)
import GHC.Internal.System.Posix.Internals (c_close, setCloseOnExec)
import GHC.Internal.System.Posix.Types (Fd(..))

import qualified GHC.Internal.Event.Array    as A
import           GHC.Internal.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)
    }

-- | Create a new epoll backend.
new :: IO E.Backend
new :: IO Backend
new = do
  epfd <- IO EPollFd
epollCreate
  evts <- A.new 64
  let !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)
  return be

delete :: EPoll -> IO ()
delete :: EPoll -> IO ()
delete EPoll
be = do
  _ <- 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
  return ()

-- | Change the set of events we are interested in for a given file
-- descriptor.
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
     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 res == 0
       then return True
       else do err <- getErrno
               if err == eNOENT
                 then with (Event ev fd) $ \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 throwErrno "modifyFdOnce"

-- | Select a set of file descriptors which are ready for I/O
-- operations and call @f@ for all ready file descriptors, passing the
-- events that are ready.
poll :: EPoll                     -- ^ state
     -> Maybe Timeout             -- ^ timeout in milliseconds
     -> (Fd -> E.Event -> IO ())  -- ^ I/O callback
     -> 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

  -- Will return zero if the system call was interrupted, in which case
  -- we just return (and try again later.)
  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

  when (n > 0) $ do
    A.forM_ events $ \Event
e -> Fd -> Event -> IO ()
f (Event -> Fd
eventFd Event
e) (EventType -> Event
toEvent (Event -> EventType
eventTypes Event
e))
    cap <- A.capacity events
    when (cap == n) $ A.ensureCapacity events (2 * cap)
  return 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)

-- | @since base-4.3.1.0
instance Storable Event where
    sizeOf :: Event -> Int
sizeOf    Event
_ = (Int
12)
{-# LINE 140 "libraries/ghc-internal/src/GHC/Internal/Event/EPoll.hsc" #-}
    alignment _ = alignment (undefined :: CInt)

    peek :: Ptr Event -> IO Event
peek Ptr Event
ptr = do
        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/ghc-internal/src/GHC/Internal/Event/EPoll.hsc" #-}
        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
{-# LINE 145 "libraries/ghc-internal/src/GHC/Internal/Event/EPoll.hsc" #-}
        let !ev = EventType -> Fd -> Event
Event (Word32 -> EventType
EventType Word32
ets) Fd
ed
        return 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/ghc-internal/src/GHC/Internal/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/ghc-internal/src/GHC/Internal/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/ghc-internal/src/GHC/Internal/Event/EPoll.hsc" #-}

newtype EventType = EventType {
      unEventType :: Word32
    } deriving ( Show       -- ^ @since base-4.4.0.0
               , Eq         -- ^ @since base-4.4.0.0
               , Num        -- ^ @since base-4.4.0.0
               , Bits       -- ^ @since base-4.4.0.0
               , FiniteBits -- ^ @since base-4.7.0.0
               )

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/ghc-internal/src/GHC/Internal/Event/EPoll.hsc" #-}

-- | Create a new epoll context, returning a file descriptor associated with the context.
-- The fd may be used for subsequent calls to this epoll context.
--
-- The size parameter to epoll_create is a hint about the expected number of handles.
--
-- The file descriptor returned from epoll_create() should be destroyed via
-- a call to close() after polling is finished
--
epollCreate :: IO EPollFd
epollCreate :: IO EPollFd
epollCreate = do
  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 -- argument is ignored
  setCloseOnExec fd
  let !epollFd' = CInt -> EPollFd
EPollFd CInt
fd
  return 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/ghc-internal/src/GHC/Internal/Event/EPoll.hsc" #-}