ccc8ec032ca3ca8496cd970ac5c376af1ebc52b1
[packages/base.git] / System / Event / EPoll.hsc
1 {-# LANGUAGE ForeignFunctionInterface, GeneralizedNewtypeDeriving,
2     NoImplicitPrelude, BangPatterns #-}
3
4 --
5 -- | A binding to the epoll I/O event notification facility
6 --
7 -- epoll is a variant of poll that can be used either as an edge-triggered or
8 -- a level-triggered interface and scales well to large numbers of watched file
9 -- descriptors.
10 --
11 -- epoll decouples monitor an fd from the process of registering it.
12 --
13 module System.Event.EPoll
14     (
15       new
16     , available
17     ) where
18
19 import qualified System.Event.Internal as E
20
21 #include "EventConfig.h"
22 #if !defined(HAVE_EPOLL)
23 import GHC.Base
24
25 new :: IO E.Backend
26 new = error "EPoll back end not implemented for this platform"
27
28 available :: Bool
29 available = False
30 {-# INLINE available #-}
31 #else
32
33 #include <sys/epoll.h>
34
35 import Control.Monad (when)
36 import Data.Bits (Bits, (.|.), (.&.))
37 import Data.Monoid (Monoid(..))
38 import Data.Word (Word32)
39 import Foreign.C.Error (throwErrnoIfMinus1, throwErrnoIfMinus1_)
40 import Foreign.C.Types (CInt)
41 import Foreign.Marshal.Utils (with)
42 import Foreign.Ptr (Ptr)
43 import Foreign.Storable (Storable(..))
44 import GHC.Base
45 import GHC.Err (undefined)
46 import GHC.Num (Num(..))
47 import GHC.Real (ceiling, fromIntegral)
48 import GHC.Show (Show)
49 import System.Posix.Internals (c_close)
50 #if !defined(HAVE_EPOLL_CREATE1)
51 import System.Posix.Internals (setCloseOnExec)
52 #endif
53 import System.Posix.Types (Fd(..))
54
55 import qualified System.Event.Array    as A
56 import           System.Event.Internal (Timeout(..))
57
58 available :: Bool
59 available = True
60 {-# INLINE available #-}
61
62 data EPoll = EPoll {
63       epollFd     :: {-# UNPACK #-} !EPollFd
64     , epollEvents :: {-# UNPACK #-} !(A.Array Event)
65     }
66
67 -- | Create a new epoll backend.
68 new :: IO E.Backend
69 new = do
70   epfd <- epollCreate
71   evts <- A.new 64
72   let !be = E.backend poll modifyFd delete (EPoll epfd evts)
73   return be
74
75 delete :: EPoll -> IO ()
76 delete be = do
77   _ <- c_close . fromEPollFd . epollFd $ be
78   return ()
79
80 -- | Change the set of events we are interested in for a given file
81 -- descriptor.
82 modifyFd :: EPoll -> Fd -> E.Event -> E.Event -> IO ()
83 modifyFd ep fd oevt nevt = with (Event (fromEvent nevt) fd) $
84                              epollControl (epollFd ep) op fd
85   where op | oevt == mempty = controlOpAdd
86            | nevt == mempty = controlOpDelete
87            | otherwise      = controlOpModify
88
89 -- | Select a set of file descriptors which are ready for I/O
90 -- operations and call @f@ for all ready file descriptors, passing the
91 -- events that are ready.
92 poll :: EPoll                     -- ^ state
93      -> Timeout                   -- ^ timeout in milliseconds
94      -> (Fd -> E.Event -> IO ())  -- ^ I/O callback
95      -> IO ()
96 poll ep timeout f = do
97   let events = epollEvents ep
98
99   -- Will return zero if the system call was interupted, in which case
100   -- we just return (and try again later.)
101   n <- A.unsafeLoad events $ \es cap ->
102        epollWait (epollFd ep) es cap $ fromTimeout timeout
103
104   when (n > 0) $ do
105     A.forM_ events $ \e -> f (eventFd e) (toEvent (eventTypes e))
106     cap <- A.capacity events
107     when (cap == n) $ A.ensureCapacity events (2 * cap)
108
109 newtype EPollFd = EPollFd {
110       fromEPollFd :: CInt
111     } deriving (Eq, Show)
112
113 data Event = Event {
114       eventTypes :: EventType
115     , eventFd    :: Fd
116     } deriving (Show)
117
118 instance Storable Event where
119     sizeOf    _ = #size struct epoll_event
120     alignment _ = alignment (undefined :: CInt)
121
122     peek ptr = do
123         ets <- #{peek struct epoll_event, events} ptr
124         ed  <- #{peek struct epoll_event, data.fd}   ptr
125         let !ev = Event (EventType ets) ed
126         return ev
127
128     poke ptr e = do
129         #{poke struct epoll_event, events} ptr (unEventType $ eventTypes e)
130         #{poke struct epoll_event, data.fd}   ptr (eventFd e)
131
132 newtype ControlOp = ControlOp CInt
133
134 #{enum ControlOp, ControlOp
135  , controlOpAdd    = EPOLL_CTL_ADD
136  , controlOpModify = EPOLL_CTL_MOD
137  , controlOpDelete = EPOLL_CTL_DEL
138  }
139
140 newtype EventType = EventType {
141       unEventType :: Word32
142     } deriving (Show, Eq, Num, Bits)
143
144 #{enum EventType, EventType
145  , epollIn  = EPOLLIN
146  , epollOut = EPOLLOUT
147  , epollErr = EPOLLERR
148  , epollHup = EPOLLHUP
149  }
150
151 -- | Create a new epoll context, returning a file descriptor associated with the context.
152 -- The fd may be used for subsequent calls to this epoll context.
153 --
154 -- The size parameter to epoll_create is a hint about the expected number of handles.
155 --
156 -- The file descriptor returned from epoll_create() should be destroyed via
157 -- a call to close() after polling is finished
158 --
159 epollCreate :: IO EPollFd
160 epollCreate = do
161   fd <- throwErrnoIfMinus1 "epollCreate" $
162 #if defined(HAVE_EPOLL_CREATE1)
163         c_epoll_create1 (#const EPOLL_CLOEXEC)
164 #else
165         c_epoll_create 256 -- argument is ignored
166   setCloseOnExec fd
167 #endif
168   let !epollFd' = EPollFd fd
169   return epollFd'
170
171 epollControl :: EPollFd -> ControlOp -> Fd -> Ptr Event -> IO ()
172 epollControl (EPollFd epfd) (ControlOp op) (Fd fd) event =
173     throwErrnoIfMinus1_ "epollControl" $ c_epoll_ctl epfd op fd event
174
175 epollWait :: EPollFd -> Ptr Event -> Int -> Int -> IO Int
176 epollWait (EPollFd epfd) events numEvents timeout =
177     fmap fromIntegral .
178     E.throwErrnoIfMinus1NoRetry "epollWait" $
179     c_epoll_wait epfd events (fromIntegral numEvents) (fromIntegral timeout)
180
181 fromEvent :: E.Event -> EventType
182 fromEvent e = remap E.evtRead  epollIn .|.
183               remap E.evtWrite epollOut
184   where remap evt to
185             | e `E.eventIs` evt = to
186             | otherwise         = 0
187
188 toEvent :: EventType -> E.Event
189 toEvent e = remap (epollIn  .|. epollErr .|. epollHup) E.evtRead `mappend`
190             remap (epollOut .|. epollErr .|. epollHup) E.evtWrite
191   where remap evt to
192             | e .&. evt /= 0 = to
193             | otherwise      = mempty
194
195 fromTimeout :: Timeout -> Int
196 fromTimeout Forever     = -1
197 fromTimeout (Timeout s) = ceiling $ 1000 * s
198
199 #if defined(HAVE_EPOLL_CREATE1)
200 foreign import ccall unsafe "sys/epoll.h epoll_create1"
201     c_epoll_create1 :: CInt -> IO CInt
202 #else
203 foreign import ccall unsafe "sys/epoll.h epoll_create"
204     c_epoll_create :: CInt -> IO CInt
205 #endif
206
207 foreign import ccall unsafe "sys/epoll.h epoll_ctl"
208     c_epoll_ctl :: CInt -> CInt -> CInt -> Ptr Event -> IO CInt
209
210 foreign import ccall safe "sys/epoll.h epoll_wait"
211     c_epoll_wait :: CInt -> Ptr Event -> CInt -> CInt -> IO CInt
212
213 #endif /* defined(HAVE_EPOLL) */