{-# LINE 1 "GHC/Event/Poll.hsc" #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE GeneralizedNewtypeDeriving
           , NoImplicitPrelude
           , BangPatterns
  #-}

module GHC.Event.Poll
    (
      new
    , available
    ) where




{-# LINE 26 "GHC/Event/Poll.hsc" #-}


import Control.Concurrent.MVar (MVar, newMVar, swapMVar)
import Data.Bits (Bits, FiniteBits, (.|.), (.&.))
import Foreign.C.Types (CInt(..), CShort(..))
import Foreign.Ptr (Ptr)
import Foreign.Storable (Storable(..))
import GHC.Base
import GHC.Conc.Sync (withMVar)
import GHC.Enum (maxBound)
import GHC.Num (Num(..))
import GHC.Real (fromIntegral, div)
import GHC.Show (Show)
import System.Posix.Types (Fd(..), CNfds(..))

import qualified GHC.Event.Array as A
import qualified GHC.Event.Internal as E

available :: Bool
available :: Bool
available = Bool
True
{-# INLINE available #-}

data Poll = Poll {
      Poll -> MVar (Array PollFd)
pollChanges :: {-# UNPACK #-} !(MVar (A.Array PollFd))
    , Poll -> Array PollFd
pollFd      :: {-# UNPACK #-} !(A.Array PollFd)
    }

new :: IO E.Backend
new :: IO Backend
new = (Poll -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int)
-> (Poll -> Fd -> Event -> Event -> IO Bool)
-> (Poll -> Fd -> Event -> IO Bool)
-> (Poll -> IO ())
-> Poll
-> 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 Poll -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
poll Poll -> Fd -> Event -> Event -> IO Bool
modifyFd Poll -> Fd -> Event -> IO Bool
modifyFdOnce (\Poll
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Poll -> Backend) -> IO Poll -> IO Backend
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM`
      (MVar (Array PollFd) -> Array PollFd -> Poll)
-> IO (MVar (Array PollFd)) -> IO (Array PollFd) -> IO Poll
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 MVar (Array PollFd) -> Array PollFd -> Poll
Poll (Array PollFd -> IO (MVar (Array PollFd))
forall a. a -> IO (MVar a)
newMVar (Array PollFd -> IO (MVar (Array PollFd)))
-> IO (Array PollFd) -> IO (MVar (Array PollFd))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Array PollFd)
forall a. IO (Array a)
A.empty) IO (Array PollFd)
forall a. IO (Array a)
A.empty

modifyFd :: Poll -> Fd -> E.Event -> E.Event -> IO Bool
modifyFd :: Poll -> Fd -> Event -> Event -> IO Bool
modifyFd Poll
p Fd
fd Event
oevt Event
nevt =
  MVar (Array PollFd) -> (Array PollFd -> IO Bool) -> IO Bool
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Poll -> MVar (Array PollFd)
pollChanges Poll
p) ((Array PollFd -> IO Bool) -> IO Bool)
-> (Array PollFd -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Array PollFd
ary -> do
    Array PollFd -> PollFd -> IO ()
forall a. Storable a => Array a -> a -> IO ()
A.snoc Array PollFd
ary (PollFd -> IO ()) -> PollFd -> IO ()
forall a b. (a -> b) -> a -> b
$ Fd -> Event -> Event -> PollFd
PollFd Fd
fd (Event -> Event
fromEvent Event
nevt) (Event -> Event
fromEvent Event
oevt)
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

modifyFdOnce :: Poll -> Fd -> E.Event -> IO Bool
modifyFdOnce :: Poll -> Fd -> Event -> IO Bool
modifyFdOnce = [Char] -> Poll -> Fd -> Event -> IO Bool
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"modifyFdOnce not supported in Poll backend"

reworkFd :: Poll -> PollFd -> IO ()
reworkFd :: Poll -> PollFd -> IO ()
reworkFd Poll
p (PollFd Fd
fd Event
npevt Event
opevt) = do
  let ary :: Array PollFd
ary = Poll -> Array PollFd
pollFd Poll
p
  if Event
opevt Event -> Event -> Bool
forall a. Eq a => a -> a -> Bool
== Event
0
    then Array PollFd -> PollFd -> IO ()
forall a. Storable a => Array a -> a -> IO ()
A.snoc Array PollFd
ary (PollFd -> IO ()) -> PollFd -> IO ()
forall a b. (a -> b) -> a -> b
$ Fd -> Event -> Event -> PollFd
PollFd Fd
fd Event
npevt Event
0
    else do
      Maybe (Int, PollFd)
found <- (PollFd -> Bool) -> Array PollFd -> IO (Maybe (Int, PollFd))
forall a.
Storable a =>
(a -> Bool) -> Array a -> IO (Maybe (Int, a))
A.findIndex ((Fd -> Fd -> Bool
forall a. Eq a => a -> a -> Bool
== Fd
fd) (Fd -> Bool) -> (PollFd -> Fd) -> PollFd -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PollFd -> Fd
pfdFd) Array PollFd
ary
      case Maybe (Int, PollFd)
found of
        Maybe (Int, PollFd)
Nothing        -> [Char] -> IO ()
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"reworkFd: event not found"
        Just (Int
i,PollFd
_)
          | Event
npevt Event -> Event -> Bool
forall a. Eq a => a -> a -> Bool
/= Event
0 -> Array PollFd -> Int -> PollFd -> IO ()
forall a. Storable a => Array a -> Int -> a -> IO ()
A.unsafeWrite Array PollFd
ary Int
i (PollFd -> IO ()) -> PollFd -> IO ()
forall a b. (a -> b) -> a -> b
$ Fd -> Event -> Event -> PollFd
PollFd Fd
fd Event
npevt Event
0
          | Bool
otherwise  -> Array PollFd -> Int -> IO ()
forall a. Storable a => Array a -> Int -> IO ()
A.removeAt Array PollFd
ary Int
i

poll :: Poll
     -> Maybe E.Timeout
     -> (Fd -> E.Event -> IO ())
     -> IO Int
poll :: Poll -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
poll Poll
p Maybe Timeout
mtout Fd -> Event -> IO ()
f = do
  let a :: Array PollFd
a = Poll -> Array PollFd
pollFd Poll
p
  Array PollFd
mods <- MVar (Array PollFd) -> Array PollFd -> IO (Array PollFd)
forall a. MVar a -> a -> IO a
swapMVar (Poll -> MVar (Array PollFd)
pollChanges Poll
p) (Array PollFd -> IO (Array PollFd))
-> IO (Array PollFd) -> IO (Array PollFd)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Array PollFd)
forall a. IO (Array a)
A.empty
  Array PollFd -> (PollFd -> IO ()) -> IO ()
forall a. Storable a => Array a -> (a -> IO ()) -> IO ()
A.forM_ Array PollFd
mods (Poll -> PollFd -> IO ()
reworkFd Poll
p)
  CInt
n <- Array PollFd -> (Ptr PollFd -> Int -> IO CInt) -> IO CInt
forall a b. Array a -> (Ptr a -> Int -> IO b) -> IO b
A.useAsPtr Array PollFd
a ((Ptr PollFd -> Int -> IO CInt) -> IO CInt)
-> (Ptr PollFd -> Int -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr PollFd
ptr Int
len ->
    [Char] -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => [Char] -> IO a -> IO a
E.throwErrnoIfMinus1NoRetry [Char]
"c_poll" (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$
    case Maybe Timeout
mtout of
      Just Timeout
tout ->
        Ptr PollFd -> CNfds -> Int -> IO CInt
c_pollLoop Ptr PollFd
ptr (Int -> CNfds
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) (Timeout -> Int
fromTimeout Timeout
tout)
      Maybe Timeout
Nothing   ->
        Ptr PollFd -> CNfds -> CInt -> IO CInt
c_poll_unsafe Ptr PollFd
ptr (Int -> CNfds
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) CInt
0
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
n CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Array PollFd
-> CInt -> (CInt -> PollFd -> IO (CInt, Bool)) -> IO ()
forall a b.
Storable a =>
Array a -> b -> (b -> a -> IO (b, Bool)) -> IO ()
A.loop Array PollFd
a CInt
0 ((CInt -> PollFd -> IO (CInt, Bool)) -> IO ())
-> (CInt -> PollFd -> IO (CInt, Bool)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CInt
i PollFd
e -> do
      let r :: Event
r = PollFd -> Event
pfdRevents PollFd
e
      if Event
r Event -> Event -> Bool
forall a. Eq a => a -> a -> Bool
/= Event
0
        then do Fd -> Event -> IO ()
f (PollFd -> Fd
pfdFd PollFd
e) (Event -> Event
toEvent Event
r)
                let i' :: CInt
i' = CInt
i CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
+ CInt
1
                (CInt, Bool) -> IO (CInt, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt
i', CInt
i' CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
n)
        else (CInt, Bool) -> IO (CInt, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt
i, Bool
True)
  Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
n)
  where
    -- The poll timeout is specified as an Int, but c_poll takes a CInt. These
    -- can't be safely coerced as on many systems (e.g. x86_64) CInt has a
    -- maxBound of (2^32 - 1), even though Int may have a significantly higher
    -- bound.
    --
    -- This function deals with timeouts greater than maxBound :: CInt, by
    -- looping until c_poll returns a non-zero value (0 indicates timeout
    -- expired) OR the full timeout has passed.
    c_pollLoop :: Ptr PollFd -> CNfds -> Int -> IO CInt
    c_pollLoop :: Ptr PollFd -> CNfds -> Int -> IO CInt
c_pollLoop Ptr PollFd
ptr CNfds
len Int
tout
        | Bool
isShortTimeout = Ptr PollFd -> CNfds -> CInt -> IO CInt
c_poll Ptr PollFd
ptr CNfds
len (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tout)
        | Bool
otherwise = do
            CInt
result <- Ptr PollFd -> CNfds -> CInt -> IO CInt
c_poll Ptr PollFd
ptr CNfds
len (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxPollTimeout)
            if CInt
result CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0
               then Ptr PollFd -> CNfds -> Int -> IO CInt
c_pollLoop Ptr PollFd
ptr CNfds
len (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
tout Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
maxPollTimeout))
               else CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
result
        where
          -- maxPollTimeout is smaller than 0 IFF Int is smaller than CInt.
          -- This means any possible Int input to poll can be safely directly
          -- converted to CInt.
          isShortTimeout :: Bool
isShortTimeout = Int
tout Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxPollTimeout Bool -> Bool -> Bool
|| Int
maxPollTimeout Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0

    -- We need to account for 3 cases:
    --     1. Int and CInt are of equal size.
    --     2. Int is larger than CInt
    --     3. Int is smaller than CInt
    --
    -- In case 1, the value of maxPollTimeout will be the maxBound of Int.
    --
    -- In case 2, the value of maxPollTimeout will be the maxBound of CInt,
    -- which is the largest value accepted by c_poll. This will result in
    -- c_pollLoop recursing if the provided timeout is larger.
    --
    -- In case 3, "fromIntegral (maxBound :: CInt) :: Int" will result in a
    -- negative Int. This will cause isShortTimeout to be true and result in
    -- the timeout being directly converted to a CInt.
    maxPollTimeout :: Int
    maxPollTimeout :: Int
maxPollTimeout = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt
forall a. Bounded a => a
maxBound :: CInt)

fromTimeout :: E.Timeout -> Int
fromTimeout :: Timeout -> Int
fromTimeout Timeout
E.Forever     = -Int
1
fromTimeout (E.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

data PollFd = PollFd {
      PollFd -> Fd
pfdFd      :: {-# UNPACK #-} !Fd
    , PollFd -> Event
pfdEvents  :: {-# UNPACK #-} !Event
    , PollFd -> Event
pfdRevents :: {-# UNPACK #-} !Event
    } deriving Show -- ^ @since 4.4.0.0

newtype Event = Event CShort
    deriving ( Eq         -- ^ @since 4.4.0.0
             , Show       -- ^ @since 4.4.0.0
             , Num        -- ^ @since 4.4.0.0
             , Storable   -- ^ @since 4.4.0.0
             , Bits       -- ^ @since 4.4.0.0
             , FiniteBits -- ^ @since 4.7.0.0
             )

pollIn     :: Event
pollIn :: Event
pollIn     = CShort -> Event
Event CShort
1
pollOut    :: Event
pollOut :: Event
pollOut    = CShort -> Event
Event CShort
4
pollErr    :: Event
pollErr :: Event
pollErr    = CShort -> Event
Event CShort
8
pollHup    :: Event
pollHup :: Event
pollHup    = CShort -> Event
Event CShort
16

{-# LINE 170 "GHC/Event/Poll.hsc" #-}

fromEvent :: E.Event -> Event
fromEvent e = remap E.evtRead  pollIn .|.
              remap E.evtWrite pollOut
  where remap evt to
            | e `E.eventIs` evt = to
            | otherwise         = 0

toEvent :: Event -> E.Event
toEvent :: Event -> Event
toEvent Event
e = Event -> Event -> Event
forall p. Monoid p => Event -> p -> p
remap (Event
pollIn Event -> Event -> Event
forall a. Bits a => a -> a -> a
.|. Event
pollErr Event -> Event -> Event
forall a. Bits a => a -> a -> a
.|. Event
pollHup)  Event
E.evtRead Event -> Event -> Event
forall a. Monoid a => a -> a -> a
`mappend`
            Event -> Event -> Event
forall p. Monoid p => Event -> p -> p
remap (Event
pollOut Event -> Event -> Event
forall a. Bits a => a -> a -> a
.|. Event
pollErr Event -> Event -> Event
forall a. Bits a => a -> a -> a
.|. Event
pollHup) Event
E.evtWrite
  where remap :: Event -> p -> p
remap Event
evt p
to
            | Event
e Event -> Event -> Event
forall a. Bits a => a -> a -> a
.&. Event
evt Event -> Event -> Bool
forall a. Eq a => a -> a -> Bool
/= Event
0 = p
to
            | Bool
otherwise      = p
forall a. Monoid a => a
mempty

-- | @since 4.3.1.0
instance Storable PollFd where
    sizeOf :: PollFd -> Int
sizeOf PollFd
_    = (Int
8)
{-# LINE 188 "GHC/Event/Poll.hsc" #-}
    alignment _ = alignment (undefined :: CInt)

    peek :: Ptr PollFd -> IO PollFd
peek Ptr PollFd
ptr = do
      Fd
fd <- (\Ptr PollFd
hsc_ptr -> Ptr PollFd -> Int -> IO Fd
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr PollFd
hsc_ptr Int
0) Ptr PollFd
ptr
{-# LINE 192 "GHC/Event/Poll.hsc" #-}
      events <- (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr
{-# LINE 193 "GHC/Event/Poll.hsc" #-}
      revents <- (\hsc_ptr -> peekByteOff hsc_ptr 6) ptr
{-# LINE 194 "GHC/Event/Poll.hsc" #-}
      let !pollFd' = PollFd fd events revents
      PollFd -> IO PollFd
forall (m :: * -> *) a. Monad m => a -> m a
return PollFd
pollFd'

    poke :: Ptr PollFd -> PollFd -> IO ()
poke Ptr PollFd
ptr PollFd
p = do
      (\Ptr PollFd
hsc_ptr -> Ptr PollFd -> Int -> Fd -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr PollFd
hsc_ptr Int
0) Ptr PollFd
ptr (PollFd -> Fd
pfdFd PollFd
p)
{-# LINE 199 "GHC/Event/Poll.hsc" #-}
      (\hsc_ptr -> pokeByteOff hsc_ptr 4) ptr (pfdEvents p)
{-# LINE 200 "GHC/Event/Poll.hsc" #-}
      (\hsc_ptr -> pokeByteOff hsc_ptr 6) ptr (pfdRevents p)
{-# LINE 201 "GHC/Event/Poll.hsc" #-}

foreign import ccall safe "poll.h poll"
    c_poll :: Ptr PollFd -> CNfds -> CInt -> IO CInt

foreign import ccall unsafe "poll.h poll"
    c_poll_unsafe :: Ptr PollFd -> CNfds -> CInt -> IO CInt

{-# LINE 208 "GHC/Event/Poll.hsc" #-}