{-# 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 Data.Word
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(..))

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 (\_ -> () -> 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 p :: Poll
p fd :: Fd
fd oevt :: Event
oevt nevt :: 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
$ \ary :: 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 "modifyFdOnce not supported in Poll backend"

reworkFd :: Poll -> PollFd -> IO ()
reworkFd :: Poll -> PollFd -> IO ()
reworkFd p :: Poll
p (PollFd fd :: Fd
fd npevt :: Event
npevt opevt :: 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
== 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 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
        Nothing        -> [Char] -> IO ()
forall a. [Char] -> a
errorWithoutStackTrace "reworkFd: event not found"
        Just (i :: Int
i,_)
          | Event
npevt Event -> Event -> Bool
forall a. Eq a => a -> a -> Bool
/= 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 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 p :: Poll
p mtout :: Maybe Timeout
mtout f :: 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 :: Ptr PollFd
ptr len :: Int
len ->
    [Char] -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => [Char] -> IO a -> IO a
E.throwErrnoIfMinus1NoRetry "c_poll" (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$
    case Maybe Timeout
mtout of
      Just tout :: Timeout
tout ->
        Ptr PollFd -> Word64 -> Int -> IO CInt
c_pollLoop Ptr PollFd
ptr (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) (Timeout -> Int
fromTimeout Timeout
tout)
      Nothing   ->
        Ptr PollFd -> Word64 -> CInt -> IO CInt
c_poll_unsafe Ptr PollFd
ptr (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) 0
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
n CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= 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 0 ((CInt -> PollFd -> IO (CInt, Bool)) -> IO ())
-> (CInt -> PollFd -> IO (CInt, Bool)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \i :: CInt
i e :: 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
/= 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
+ 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 -> (Word64) -> Int -> IO CInt
{-# LINE 114 "GHC/Event/Poll.hsc" #-}
    c_pollLoop ptr len tout
        | isShortTimeout = c_poll ptr len (fromIntegral tout)
        | otherwise = do
            result <- c_poll ptr len (fromIntegral maxPollTimeout)
            if result == 0
               then c_pollLoop ptr len (fromIntegral (tout - maxPollTimeout))
               else return 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 = tout <= maxPollTimeout || maxPollTimeout < 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 E.Forever     = -1
fromTimeout (E.Timeout s :: 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` 1000000
  where
    divRoundUp :: a -> a -> a
divRoundUp num :: a
num denom :: 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
- 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
             )

-- We have to duplicate the whole enum like this in order for the
-- hsc2hs cross-compilation mode to work

{-# LINE 176 "GHC/Event/Poll.hsc" #-}
pollIn     :: Event
pollIn :: Event
pollIn     = CShort -> Event
Event 1
pollOut    :: Event
pollOut :: Event
pollOut    = CShort -> Event
Event 4
pollErr    :: Event
pollErr :: Event
pollErr    = CShort -> Event
Event 8
pollHup    :: Event
pollHup :: Event
pollHup    = CShort -> Event
Event 16

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

{-# LINE 183 "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 e :: 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 evt :: Event
evt to :: 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
/= 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 _    = (8)
{-# LINE 201 "GHC/Event/Poll.hsc" #-}
    alignment _ = alignment (undefined :: CInt)

    peek :: Ptr PollFd -> IO PollFd
peek ptr :: Ptr PollFd
ptr = do
      Fd
fd <- (\hsc_ptr :: Ptr PollFd
hsc_ptr -> Ptr PollFd -> Int -> IO Fd
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr PollFd
hsc_ptr 0) Ptr PollFd
ptr
{-# LINE 205 "GHC/Event/Poll.hsc" #-}
      events <- (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr
{-# LINE 206 "GHC/Event/Poll.hsc" #-}
      revents <- (\hsc_ptr -> peekByteOff hsc_ptr 6) ptr
{-# LINE 207 "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 :: Ptr PollFd
ptr p :: PollFd
p = do
      (\hsc_ptr :: Ptr PollFd
hsc_ptr -> Ptr PollFd -> Int -> Fd -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr PollFd
hsc_ptr 0) Ptr PollFd
ptr (PollFd -> Fd
pfdFd PollFd
p)
{-# LINE 212 "GHC/Event/Poll.hsc" #-}
      (\hsc_ptr -> pokeByteOff hsc_ptr 4) ptr (pfdEvents p)
{-# LINE 213 "GHC/Event/Poll.hsc" #-}
      (\hsc_ptr -> pokeByteOff hsc_ptr 6) ptr (pfdRevents p)
{-# LINE 214 "GHC/Event/Poll.hsc" #-}

foreign import ccall safe "poll.h poll"
    c_poll :: Ptr PollFd -> (Word64) -> CInt -> IO CInt
{-# LINE 217 "GHC/Event/Poll.hsc" #-}

foreign import ccall unsafe "poll.h poll"
    c_poll_unsafe :: Ptr PollFd -> (Word64) -> CInt -> IO CInt
{-# LINE 220 "GHC/Event/Poll.hsc" #-}

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