2 , ForeignFunctionInterface
3 , GeneralizedNewtypeDeriving
14 #include "EventConfig.h"
16 #if !defined(HAVE_POLL_H)
20 new = error "Poll back end not implemented for this platform"
24 {-# INLINE available #-}
28 import Control.Concurrent.MVar (MVar, newMVar, swapMVar)
29 import Control.Monad ((=<<), liftM, liftM2, unless)
30 import Data.Bits (Bits, (.|.), (.&.))
31 import Data.Maybe (Maybe(..))
32 import Data.Monoid (Monoid(..))
33 import Foreign.C.Types (CInt, CShort, CULong)
34 import Foreign.Ptr (Ptr)
35 import Foreign.Storable (Storable(..))
37 import GHC.Conc.Sync (withMVar)
38 import GHC.Err (undefined)
39 import GHC.Num (Num(..))
40 import GHC.Real (ceiling, fromIntegral)
41 import GHC.Show (Show)
42 import System.Posix.Types (Fd(..))
44 import qualified GHC.Event.Array as A
45 import qualified GHC.Event.Internal as E
49 {-# INLINE available #-}
52 pollChanges :: {-# UNPACK #-} !(MVar (A.Array PollFd))
53 , pollFd :: {-# UNPACK #-} !(A.Array PollFd)
57 new = E.backend poll modifyFd (\_ -> return ()) `liftM`
58 liftM2 Poll (newMVar =<< A.empty) A.empty
60 modifyFd :: Poll -> Fd -> E.Event -> E.Event -> IO ()
61 modifyFd p fd oevt nevt =
62 withMVar (pollChanges p) $ \ary ->
63 A.snoc ary $ PollFd fd (fromEvent nevt) (fromEvent oevt)
65 reworkFd :: Poll -> PollFd -> IO ()
66 reworkFd p (PollFd fd npevt opevt) = do
69 then A.snoc ary $ PollFd fd npevt 0
71 found <- A.findIndex ((== fd) . pfdFd) ary
73 Nothing -> error "reworkFd: event not found"
75 | npevt /= 0 -> A.unsafeWrite ary i $ PollFd fd npevt 0
76 | otherwise -> A.removeAt ary i
80 -> (Fd -> E.Event -> IO ())
84 mods <- swapMVar (pollChanges p) =<< A.empty
85 A.forM_ mods (reworkFd p)
86 n <- A.useAsPtr a $ \ptr len -> E.throwErrnoIfMinus1NoRetry "c_poll" $
87 c_poll ptr (fromIntegral len) (fromIntegral (fromTimeout tout))
89 A.loop a 0 $ \i e -> do
92 then do f (pfdFd e) (toEvent r)
97 fromTimeout :: E.Timeout -> Int
98 fromTimeout E.Forever = -1
99 fromTimeout (E.Timeout s) = ceiling $ 1000 * s
101 data PollFd = PollFd {
102 pfdFd :: {-# UNPACK #-} !Fd
103 , pfdEvents :: {-# UNPACK #-} !Event
104 , pfdRevents :: {-# UNPACK #-} !Event
107 newtype Event = Event CShort
108 deriving (Eq, Show, Num, Storable, Bits)
114 , pollRdHup = POLLRDHUP
120 fromEvent :: E.Event -> Event
121 fromEvent e = remap E.evtRead pollIn .|.
122 remap E.evtWrite pollOut
124 | e `E.eventIs` evt = to
127 toEvent :: Event -> E.Event
128 toEvent e = remap (pollIn .|. pollErr .|. pollHup) E.evtRead `mappend`
129 remap (pollOut .|. pollErr .|. pollHup) E.evtWrite
131 | e .&. evt /= 0 = to
134 instance Storable PollFd where
135 sizeOf _ = #size struct pollfd
136 alignment _ = alignment (undefined :: CInt)
139 fd <- #{peek struct pollfd, fd} ptr
140 events <- #{peek struct pollfd, events} ptr
141 revents <- #{peek struct pollfd, revents} ptr
142 let !pollFd' = PollFd fd events revents
146 #{poke struct pollfd, fd} ptr (pfdFd p)
147 #{poke struct pollfd, events} ptr (pfdEvents p)
148 #{poke struct pollfd, revents} ptr (pfdRevents p)
150 foreign import ccall safe "poll.h poll"
151 c_poll :: Ptr PollFd -> CULong -> CInt -> IO CInt
153 #endif /* defined(HAVE_POLL_H) */