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)
110 -- We have to duplicate the whole enum like this in order for the
111 -- hsc2hs cross-compilation mode to work
116 , pollRdHup = POLLRDHUP
129 fromEvent :: E.Event -> Event
130 fromEvent e = remap E.evtRead pollIn .|.
131 remap E.evtWrite pollOut
133 | e `E.eventIs` evt = to
136 toEvent :: Event -> E.Event
137 toEvent e = remap (pollIn .|. pollErr .|. pollHup) E.evtRead `mappend`
138 remap (pollOut .|. pollErr .|. pollHup) E.evtWrite
140 | e .&. evt /= 0 = to
143 instance Storable PollFd where
144 sizeOf _ = #size struct pollfd
145 alignment _ = alignment (undefined :: CInt)
148 fd <- #{peek struct pollfd, fd} ptr
149 events <- #{peek struct pollfd, events} ptr
150 revents <- #{peek struct pollfd, revents} ptr
151 let !pollFd' = PollFd fd events revents
155 #{poke struct pollfd, fd} ptr (pfdFd p)
156 #{poke struct pollfd, events} ptr (pfdEvents p)
157 #{poke struct pollfd, revents} ptr (pfdRevents p)
159 foreign import ccall safe "poll.h poll"
160 c_poll :: Ptr PollFd -> CULong -> CInt -> IO CInt
162 #endif /* defined(HAVE_POLL_H) */