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