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

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




{-# LINE 26 "libraries/base/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
External instance of the constraint type Monad IO
return ()) (Poll -> Backend) -> IO Poll -> IO Backend
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
External instance of the constraint type Monad IO
`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
External instance of the constraint type Monad IO
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
External instance of the constraint type Monad IO
=<< 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 ()
Instance of class: Storable of the constraint type Storable PollFd
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
External instance of the constraint type Monad IO
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
Instance of class: Eq of the constraint type Eq Event
== Event
0
    then Array PollFd -> PollFd -> IO ()
forall a. Storable a => Array a -> a -> IO ()
Instance of class: Storable of the constraint type Storable PollFd
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))
Instance of class: Storable of the constraint type Storable PollFd
A.findIndex ((Fd -> Fd -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq Fd
== 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
Instance of class: Eq of the constraint type Eq Event
/= Event
0 -> Array PollFd -> Int -> PollFd -> IO ()
forall a. Storable a => Array a -> Int -> a -> IO ()
Instance of class: Storable of the constraint type Storable PollFd
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 ()
Instance of class: Storable of the constraint type Storable PollFd
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
External instance of the constraint type Monad IO
=<< IO (Array PollFd)
forall a. IO (Array a)
A.empty
  Array PollFd -> (PollFd -> IO ()) -> IO ()
forall a. Storable a => Array a -> (a -> IO ()) -> IO ()
Instance of class: Storable of the constraint type Storable PollFd
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
External instance of the constraint type Num CInt
External instance of the constraint type Eq CInt
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
External instance of the constraint type Num CNfds
External instance of the constraint type Integral Int
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
External instance of the constraint type Num CNfds
External instance of the constraint type Integral Int
fromIntegral Int
len) CInt
0
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
External instance of the constraint type Applicative IO
when (CInt
n CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq CInt
/= 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 ()
Instance of class: Storable of the constraint type Storable PollFd
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
Instance of class: Eq of the constraint type Eq Event
/= 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
External instance of the constraint type Num CInt
+ CInt
1
                (CInt, Bool) -> IO (CInt, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
return (CInt
i', CInt
i' CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq CInt
== CInt
n)
        else (CInt, Bool) -> IO (CInt, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
return (CInt
i, Bool
True)
  Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
return (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
External instance of the constraint type Num Int
External instance of the constraint type Integral CInt
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
External instance of the constraint type Num CInt
External instance of the constraint type Integral Int
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
External instance of the constraint type Num CInt
External instance of the constraint type Integral Int
fromIntegral Int
maxPollTimeout)
            if CInt
result CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq CInt
== 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
External instance of the constraint type Num Int
External instance of the constraint type Integral Int
fromIntegral (Int
tout Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
- Int
maxPollTimeout))
               else CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
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
External instance of the constraint type Ord Int
<= Int
maxPollTimeout Bool -> Bool -> Bool
|| Int
maxPollTimeout Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
External instance of the constraint type Ord Int
< 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
External instance of the constraint type Num Int
External instance of the constraint type Integral CInt
fromIntegral (CInt
forall a. Bounded a => a
External instance of the constraint type Bounded CInt
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
External instance of the constraint type Num Int
External instance of the constraint type Integral Word64
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ Word64
s Word64 -> Word64 -> Word64
forall {a}. Integral a => a -> a -> a
External instance of the constraint type Integral Word64
`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
External instance of the constraint type forall a. Real a => Num a
External instance of the constraint type forall a. Integral a => Real a
Evidence bound by a type signature of the constraint type Integral a
+ a
denom a -> a -> a
forall a. Num a => a -> a -> a
External instance of the constraint type forall a. Real a => Num a
External instance of the constraint type forall a. Integral a => Real a
Evidence bound by a type signature of the constraint type Integral a
- a
1) a -> a -> a
forall {a}. Integral a => a -> a -> a
Evidence bound by a type signature of the constraint type Integral 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 "libraries/base/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
External instance of the constraint type Monoid Event
remap (Event
pollIn Event -> Event -> Event
forall a. Bits a => a -> a -> a
Instance of class: Bits of the constraint type Bits Event
.|. Event
pollErr Event -> Event -> Event
forall a. Bits a => a -> a -> a
Instance of class: Bits of the constraint type Bits Event
.|. Event
pollHup)  Event
E.evtRead Event -> Event -> Event
forall a. Monoid a => a -> a -> a
External instance of the constraint type Monoid Event
`mappend`
            Event -> Event -> Event
forall {p}. Monoid p => Event -> p -> p
External instance of the constraint type Monoid Event
remap (Event
pollOut Event -> Event -> Event
forall a. Bits a => a -> a -> a
Instance of class: Bits of the constraint type Bits Event
.|. Event
pollErr Event -> Event -> Event
forall a. Bits a => a -> a -> a
Instance of class: Bits of the constraint type Bits Event
.|. 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
Instance of class: Bits of the constraint type Bits Event
.&. Event
evt Event -> Event -> Bool
forall a. Eq a => a -> a -> Bool
Instance of class: Eq of the constraint type Eq Event
/= Event
0 = p
to
            | Bool
otherwise      = p
forall a. Monoid a => a
Evidence bound by a type signature of the constraint type Monoid p
mempty

-- | @since 4.3.1.0
instance Storable PollFd where
    sizeOf :: PollFd -> Int
sizeOf PollFd
_    = (Int
8)
{-# LINE 188 "libraries/base/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
External instance of the constraint type Storable Fd
peekByteOff Ptr PollFd
hsc_ptr Int
0) Ptr PollFd
ptr
{-# LINE 192 "libraries/base/GHC/Event/Poll.hsc" #-}
      events <- (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr
{-# LINE 193 "libraries/base/GHC/Event/Poll.hsc" #-}
      revents <- (\hsc_ptr -> peekByteOff hsc_ptr 6) ptr
{-# LINE 194 "libraries/base/GHC/Event/Poll.hsc" #-}
      let !pollFd' = PollFd fd events revents
      PollFd -> IO PollFd
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
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 ()
External instance of the constraint type Storable Fd
pokeByteOff Ptr PollFd
hsc_ptr Int
0) Ptr PollFd
ptr (PollFd -> Fd
pfdFd PollFd
p)
{-# LINE 199 "libraries/base/GHC/Event/Poll.hsc" #-}
      (\hsc_ptr -> pokeByteOff hsc_ptr 4) ptr (pfdEvents p)
{-# LINE 200 "libraries/base/GHC/Event/Poll.hsc" #-}
      (\hsc_ptr -> pokeByteOff hsc_ptr 6) ptr (pfdRevents p)
{-# LINE 201 "libraries/base/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 "libraries/base/GHC/Event/Poll.hsc" #-}