{-# 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 = 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM`
      forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 MVar (Array PollFd) -> Array PollFd -> Poll
Poll (forall a. a -> IO (MVar a)
newMVar forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. IO (Array a)
A.empty) 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 =
  forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Poll -> MVar (Array PollFd)
pollChanges Poll
p) forall a b. (a -> b) -> a -> b
$ \Array PollFd
ary -> do
    forall a. Storable a => Array a -> a -> IO ()
A.snoc Array PollFd
ary forall a b. (a -> b) -> a -> b
$ Fd -> Event -> Event -> PollFd
PollFd Fd
fd (Event -> Event
fromEvent Event
nevt) (Event -> Event
fromEvent Event
oevt)
    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 = 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 forall a. Eq a => a -> a -> Bool
== Event
0
    then forall a. Storable a => Array a -> a -> IO ()
A.snoc Array PollFd
ary forall a b. (a -> b) -> a -> b
$ Fd -> Event -> Event -> PollFd
PollFd Fd
fd Event
npevt Event
0
    else do
      Maybe (Int, PollFd)
found <- forall a.
Storable a =>
(a -> Bool) -> Array a -> IO (Maybe (Int, a))
A.findIndex ((forall a. Eq a => a -> a -> Bool
== Fd
fd) 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        -> forall a. [Char] -> a
errorWithoutStackTrace [Char]
"reworkFd: event not found"
        Just (Int
i,PollFd
_)
          | Event
npevt forall a. Eq a => a -> a -> Bool
/= Event
0 -> forall a. Storable a => Array a -> Int -> a -> IO ()
A.unsafeWrite Array PollFd
ary Int
i forall a b. (a -> b) -> a -> b
$ Fd -> Event -> Event -> PollFd
PollFd Fd
fd Event
npevt Event
0
          | Bool
otherwise  -> 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 <- forall a. MVar a -> a -> IO a
swapMVar (Poll -> MVar (Array PollFd)
pollChanges Poll
p) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. IO (Array a)
A.empty
  forall a. Storable a => Array a -> (a -> IO ()) -> IO ()
A.forM_ Array PollFd
mods (Poll -> PollFd -> IO ()
reworkFd Poll
p)
  CInt
n <- forall a b. Array a -> (Ptr a -> Int -> IO b) -> IO b
A.useAsPtr Array PollFd
a forall a b. (a -> b) -> a -> b
$ \Ptr PollFd
ptr Int
len ->
    forall a. (Eq a, Num a) => [Char] -> IO a -> IO a
E.throwErrnoIfMinus1NoRetry [Char]
"c_poll" 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 (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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) CInt
0
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
n forall a. Eq a => a -> a -> Bool
/= CInt
0) forall a b. (a -> b) -> a -> b
$
    forall a b.
Storable a =>
Array a -> b -> (b -> a -> IO (b, Bool)) -> IO ()
A.loop Array PollFd
a CInt
0 forall a b. (a -> b) -> a -> b
$ \CInt
i PollFd
e -> do
      let r :: Event
r = PollFd -> Event
pfdRevents PollFd
e
      if Event
r 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 forall a. Num a => a -> a -> a
+ CInt
1
                forall (m :: * -> *) a. Monad m => a -> m a
return (CInt
i', CInt
i' forall a. Eq a => a -> a -> Bool
== CInt
n)
        else forall (m :: * -> *) a. Monad m => a -> m a
return (CInt
i, Bool
True)
  forall (m :: * -> *) a. Monad m => a -> m a
return (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 (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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxPollTimeout)
            if CInt
result forall a. Eq a => a -> a -> Bool
== CInt
0
               then Ptr PollFd -> CNfds -> Int -> IO CInt
c_pollLoop Ptr PollFd
ptr CNfds
len (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
tout forall a. Num a => a -> a -> a
- Int
maxPollTimeout))
               else 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 forall a. Ord a => a -> a -> Bool
<= Int
maxPollTimeout Bool -> Bool -> Bool
|| Int
maxPollTimeout 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (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) = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Word64
s forall {a}. Integral a => a -> a -> a
`divRoundUp` Word64
1000000
  where
    divRoundUp :: a -> a -> a
divRoundUp a
num a
denom = (a
num forall a. Num a => a -> a -> a
+ a
denom forall a. Num a => a -> a -> a
- a
1) 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 Int -> PollFd -> ShowS
[PollFd] -> ShowS
PollFd -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PollFd] -> ShowS
$cshowList :: [PollFd] -> ShowS
show :: PollFd -> [Char]
$cshow :: PollFd -> [Char]
showsPrec :: Int -> PollFd -> ShowS
$cshowsPrec :: Int -> PollFd -> ShowS
Show -- ^ @since 4.4.0.0

newtype Event = Event CShort
    deriving ( Event -> Event -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Event -> Event -> Bool
$c/= :: Event -> Event -> Bool
== :: Event -> Event -> Bool
$c== :: Event -> Event -> Bool
Eq         -- ^ @since 4.4.0.0
             , Int -> Event -> ShowS
[Event] -> ShowS
Event -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Event] -> ShowS
$cshowList :: [Event] -> ShowS
show :: Event -> [Char]
$cshow :: Event -> [Char]
showsPrec :: Int -> Event -> ShowS
$cshowsPrec :: Int -> Event -> ShowS
Show       -- ^ @since 4.4.0.0
             , Integer -> Event
Event -> Event
Event -> Event -> Event
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Event
$cfromInteger :: Integer -> Event
signum :: Event -> Event
$csignum :: Event -> Event
abs :: Event -> Event
$cabs :: Event -> Event
negate :: Event -> Event
$cnegate :: Event -> Event
* :: Event -> Event -> Event
$c* :: Event -> Event -> Event
- :: Event -> Event -> Event
$c- :: Event -> Event -> Event
+ :: Event -> Event -> Event
$c+ :: Event -> Event -> Event
Num        -- ^ @since 4.4.0.0
             , Ptr Event -> IO Event
Ptr Event -> Int -> IO Event
Ptr Event -> Int -> Event -> IO ()
Ptr Event -> Event -> IO ()
Event -> Int
forall b. Ptr b -> Int -> IO Event
forall b. Ptr b -> Int -> Event -> IO ()
forall a.
(a -> Int)
-> (a -> Int)
-> (Ptr a -> Int -> IO a)
-> (Ptr a -> Int -> a -> IO ())
-> (forall b. Ptr b -> Int -> IO a)
-> (forall b. Ptr b -> Int -> a -> IO ())
-> (Ptr a -> IO a)
-> (Ptr a -> a -> IO ())
-> Storable a
poke :: Ptr Event -> Event -> IO ()
$cpoke :: Ptr Event -> Event -> IO ()
peek :: Ptr Event -> IO Event
$cpeek :: Ptr Event -> IO Event
pokeByteOff :: forall b. Ptr b -> Int -> Event -> IO ()
$cpokeByteOff :: forall b. Ptr b -> Int -> Event -> IO ()
peekByteOff :: forall b. Ptr b -> Int -> IO Event
$cpeekByteOff :: forall b. Ptr b -> Int -> IO Event
pokeElemOff :: Ptr Event -> Int -> Event -> IO ()
$cpokeElemOff :: Ptr Event -> Int -> Event -> IO ()
peekElemOff :: Ptr Event -> Int -> IO Event
$cpeekElemOff :: Ptr Event -> Int -> IO Event
alignment :: Event -> Int
$calignment :: Event -> Int
sizeOf :: Event -> Int
$csizeOf :: Event -> Int
Storable   -- ^ @since 4.4.0.0
             , Eq Event
Event
Int -> Event
Event -> Bool
Event -> Int
Event -> Maybe Int
Event -> Event
Event -> Int -> Bool
Event -> Int -> Event
Event -> Event -> Event
forall a.
Eq a
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> a
-> (Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> Bool)
-> (a -> Maybe Int)
-> (a -> Int)
-> (a -> Bool)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int)
-> Bits a
popCount :: Event -> Int
$cpopCount :: Event -> Int
rotateR :: Event -> Int -> Event
$crotateR :: Event -> Int -> Event
rotateL :: Event -> Int -> Event
$crotateL :: Event -> Int -> Event
unsafeShiftR :: Event -> Int -> Event
$cunsafeShiftR :: Event -> Int -> Event
shiftR :: Event -> Int -> Event
$cshiftR :: Event -> Int -> Event
unsafeShiftL :: Event -> Int -> Event
$cunsafeShiftL :: Event -> Int -> Event
shiftL :: Event -> Int -> Event
$cshiftL :: Event -> Int -> Event
isSigned :: Event -> Bool
$cisSigned :: Event -> Bool
bitSize :: Event -> Int
$cbitSize :: Event -> Int
bitSizeMaybe :: Event -> Maybe Int
$cbitSizeMaybe :: Event -> Maybe Int
testBit :: Event -> Int -> Bool
$ctestBit :: Event -> Int -> Bool
complementBit :: Event -> Int -> Event
$ccomplementBit :: Event -> Int -> Event
clearBit :: Event -> Int -> Event
$cclearBit :: Event -> Int -> Event
setBit :: Event -> Int -> Event
$csetBit :: Event -> Int -> Event
bit :: Int -> Event
$cbit :: Int -> Event
zeroBits :: Event
$czeroBits :: Event
rotate :: Event -> Int -> Event
$crotate :: Event -> Int -> Event
shift :: Event -> Int -> Event
$cshift :: Event -> Int -> Event
complement :: Event -> Event
$ccomplement :: Event -> Event
xor :: Event -> Event -> Event
$cxor :: Event -> Event -> Event
.|. :: Event -> Event -> Event
$c.|. :: Event -> Event -> Event
.&. :: Event -> Event -> Event
$c.&. :: Event -> Event -> Event
Bits       -- ^ @since 4.4.0.0
             , Bits Event
Event -> Int
forall b.
Bits b -> (b -> Int) -> (b -> Int) -> (b -> Int) -> FiniteBits b
countTrailingZeros :: Event -> Int
$ccountTrailingZeros :: Event -> Int
countLeadingZeros :: Event -> Int
$ccountLeadingZeros :: Event -> Int
finiteBitSize :: Event -> Int
$cfiniteBitSize :: Event -> Int
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 = forall {p}. Monoid p => Event -> p -> p
remap (Event
pollIn forall a. Bits a => a -> a -> a
.|. Event
pollErr forall a. Bits a => a -> a -> a
.|. Event
pollHup)  Event
E.evtRead forall a. Monoid a => a -> a -> a
`mappend`
            forall {p}. Monoid p => Event -> p -> p
remap (Event
pollOut forall a. Bits a => a -> a -> a
.|. Event
pollErr forall a. Bits a => a -> a -> a
.|. Event
pollHup) Event
E.evtWrite
  where remap :: Event -> p -> p
remap Event
evt p
to
            | Event
e forall a. Bits a => a -> a -> a
.&. Event
evt forall a. Eq a => a -> a -> Bool
/= Event
0 = p
to
            | Bool
otherwise      = forall a. Monoid a => a
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 -> forall a b. Storable a => Ptr b -> Int -> IO a
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
      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 -> 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 "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" #-}