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