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