1 {-# LANGUAGE ForeignFunctionInterface, GeneralizedNewtypeDeriving,
4 module System.Event.Poll
10 #include "EventConfig.h"
12 #if !defined(HAVE_POLL_H)
16 new = error "Poll back end not implemented for this platform"
20 {-# INLINE available #-}
24 import Control.Concurrent.MVar (MVar, newMVar, swapMVar)
25 import Control.Monad ((=<<), liftM, liftM2, unless)
26 import Data.Bits (Bits, (.|.), (.&.))
27 import Data.Maybe (Maybe(..))
28 import Data.Monoid (Monoid(..))
29 import Foreign.C.Types (CInt, CShort, CULong)
30 import Foreign.Ptr (Ptr)
31 import Foreign.Storable (Storable(..))
33 import GHC.Conc.Sync (withMVar)
34 import GHC.Err (undefined)
35 import GHC.Num (Num(..))
36 import GHC.Real (ceiling, fromIntegral)
37 import GHC.Show (Show)
38 import System.Posix.Types (Fd(..))
40 import qualified System.Event.Array as A
41 import qualified System.Event.Internal as E
45 {-# INLINE available #-}
48 pollChanges :: {-# UNPACK #-} !(MVar (A.Array PollFd))
49 , pollFd :: {-# UNPACK #-} !(A.Array PollFd)
53 new = E.backend poll modifyFd (\_ -> return ()) `liftM`
54 liftM2 Poll (newMVar =<< A.empty) A.empty
56 modifyFd :: Poll -> Fd -> E.Event -> E.Event -> IO ()
57 modifyFd p fd oevt nevt =
58 withMVar (pollChanges p) $ \ary ->
59 A.snoc ary $ PollFd fd (fromEvent nevt) (fromEvent oevt)
61 reworkFd :: Poll -> PollFd -> IO ()
62 reworkFd p (PollFd fd npevt opevt) = do
65 then A.snoc ary $ PollFd fd npevt 0
67 found <- A.findIndex ((== fd) . pfdFd) ary
69 Nothing -> error "reworkFd: event not found"
71 | npevt /= 0 -> A.unsafeWrite ary i $ PollFd fd npevt 0
72 | otherwise -> A.removeAt ary i
76 -> (Fd -> E.Event -> IO ())
80 mods <- swapMVar (pollChanges p) =<< A.empty
81 A.forM_ mods (reworkFd p)
82 n <- A.useAsPtr a $ \ptr len -> E.throwErrnoIfMinus1NoRetry "c_poll" $
83 c_poll ptr (fromIntegral len) (fromIntegral (fromTimeout tout))
85 A.loop a 0 $ \i e -> do
88 then do f (pfdFd e) (toEvent r)
93 fromTimeout :: E.Timeout -> Int
94 fromTimeout E.Forever = -1
95 fromTimeout (E.Timeout s) = ceiling $ 1000 * s
97 data PollFd = PollFd {
98 pfdFd :: {-# UNPACK #-} !Fd
99 , pfdEvents :: {-# UNPACK #-} !Event
100 , pfdRevents :: {-# UNPACK #-} !Event
103 newtype Event = Event CShort
104 deriving (Eq, Show, Num, Storable, Bits)
110 , pollRdHup = POLLRDHUP
116 fromEvent :: E.Event -> Event
117 fromEvent e = remap E.evtRead pollIn .|.
118 remap E.evtWrite pollOut
120 | e `E.eventIs` evt = to
123 toEvent :: Event -> E.Event
124 toEvent e = remap (pollIn .|. pollErr .|. pollHup) E.evtRead `mappend`
125 remap (pollOut .|. pollErr .|. pollHup) E.evtWrite
127 | e .&. evt /= 0 = to
130 instance Storable PollFd where
131 sizeOf _ = #size struct pollfd
132 alignment _ = alignment (undefined :: CInt)
135 fd <- #{peek struct pollfd, fd} ptr
136 events <- #{peek struct pollfd, events} ptr
137 revents <- #{peek struct pollfd, revents} ptr
138 let !pollFd' = PollFd fd events revents
142 #{poke struct pollfd, fd} ptr (pfdFd p)
143 #{poke struct pollfd, events} ptr (pfdEvents p)
144 #{poke struct pollfd, revents} ptr (pfdRevents p)
146 foreign import ccall safe "poll.h poll"
147 c_poll :: Ptr PollFd -> CULong -> CInt -> IO CInt
149 #endif /* defined(HAVE_POLL_H) */