{-# 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
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
isShortTimeout = tout <= maxPollTimeout || maxPollTimeout < 0
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
newtype Event = Event CShort
deriving ( Eq
, Show
, Num
, Storable
, Bits
, FiniteBits
)
{-# 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
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" #-}