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