1 {-# LANGUAGE ForeignFunctionInterface, GeneralizedNewtypeDeriving,
2 NoImplicitPrelude, RecordWildCards, BangPatterns #-}
4 module System.Event.KQueue
10 import qualified System.Event.Internal as E
12 #include "EventConfig.h"
13 #if !defined(HAVE_KQUEUE)
17 new = error "KQueue back end not implemented for this platform"
21 {-# INLINE available #-}
24 import Control.Concurrent.MVar (MVar, newMVar, swapMVar, withMVar)
25 import Control.Monad (when, unless)
26 import Data.Bits (Bits(..))
27 import Data.Word (Word16, Word32)
28 import Foreign.C.Error (throwErrnoIfMinus1)
29 import Foreign.C.Types (CInt, CLong, CTime)
30 import Foreign.Marshal.Alloc (alloca)
31 import Foreign.Ptr (Ptr, nullPtr)
32 import Foreign.Storable (Storable(..))
34 import GHC.Enum (toEnum)
35 import GHC.Err (undefined)
36 import GHC.Num (Num(..))
37 import GHC.Real (ceiling, floor, fromIntegral)
38 import GHC.Show (Show(show))
39 import System.Event.Internal (Timeout(..))
40 import System.Posix.Internals (c_close)
41 import System.Posix.Types (Fd(..))
42 import qualified System.Event.Array as A
44 #if defined(HAVE_KEVENT64)
45 import Data.Int (Int64)
46 import Data.Word (Word64)
47 import Foreign.C.Types (CUInt)
49 import Foreign.C.Types (CIntPtr, CUIntPtr)
52 #include <sys/types.h>
53 #include <sys/event.h>
56 -- Handle brokenness on some BSD variants, notably OS X up to at least
57 -- 10.6. If NOTE_EOF isn't available, we have no way to receive a
58 -- notification from the kernel when we reach EOF on a plain file.
65 {-# INLINE available #-}
67 ------------------------------------------------------------------------
70 data EventQueue = EventQueue {
71 eqFd :: {-# UNPACK #-} !QueueFd
72 , eqChanges :: {-# UNPACK #-} !(MVar (A.Array Event))
73 , eqEvents :: {-# UNPACK #-} !(A.Array Event)
80 changes <- newMVar changesArr
82 let !be = E.backend poll modifyFd delete (EventQueue qfd changes events)
85 delete :: EventQueue -> IO ()
87 _ <- c_close . fromQueueFd . eqFd $ q
90 modifyFd :: EventQueue -> Fd -> E.Event -> E.Event -> IO ()
91 modifyFd q fd oevt nevt = withMVar (eqChanges q) $ \ch -> do
92 let addChange filt flag = A.snoc ch $ event fd filt flag noteEOF
93 when (oevt `E.eventIs` E.evtRead) $ addChange filterRead flagDelete
94 when (oevt `E.eventIs` E.evtWrite) $ addChange filterWrite flagDelete
95 when (nevt `E.eventIs` E.evtRead) $ addChange filterRead flagAdd
96 when (nevt `E.eventIs` E.evtWrite) $ addChange filterWrite flagAdd
100 -> (Fd -> E.Event -> IO ())
102 poll EventQueue{..} tout f = do
103 changesArr <- A.empty
104 changes <- swapMVar eqChanges changesArr
105 changesLen <- A.length changes
106 len <- A.length eqEvents
107 when (changesLen > len) $ A.ensureCapacity eqEvents (2 * changesLen)
108 n <- A.useAsPtr changes $ \changesPtr chLen ->
109 A.unsafeLoad eqEvents $ \evPtr evCap ->
110 withTimeSpec (fromTimeout tout) $
111 kevent eqFd changesPtr chLen evPtr evCap
114 cap <- A.capacity eqEvents
115 when (n == cap) $ A.ensureCapacity eqEvents (2 * cap)
116 A.forM_ eqEvents $ \e -> f (fromIntegral (ident e)) (toEvent (filter e))
118 ------------------------------------------------------------------------
121 newtype QueueFd = QueueFd {
123 } deriving (Eq, Show)
125 #if defined(HAVE_KEVENT64)
126 data Event = KEvent64 {
127 ident :: {-# UNPACK #-} !Word64
128 , filter :: {-# UNPACK #-} !Filter
129 , flags :: {-# UNPACK #-} !Flag
130 , fflags :: {-# UNPACK #-} !FFlag
131 , data_ :: {-# UNPACK #-} !Int64
132 , udata :: {-# UNPACK #-} !Word64
133 , ext0 :: {-# UNPACK #-} !Word64
134 , ext1 :: {-# UNPACK #-} !Word64
137 event :: Fd -> Filter -> Flag -> FFlag -> Event
138 event fd filt flag fflag = KEvent64 (fromIntegral fd) filt flag fflag 0 0 0 0
140 instance Storable Event where
141 sizeOf _ = #size struct kevent64_s
142 alignment _ = alignment (undefined :: CInt)
145 ident' <- #{peek struct kevent64_s, ident} ptr
146 filter' <- #{peek struct kevent64_s, filter} ptr
147 flags' <- #{peek struct kevent64_s, flags} ptr
148 fflags' <- #{peek struct kevent64_s, fflags} ptr
149 data' <- #{peek struct kevent64_s, data} ptr
150 udata' <- #{peek struct kevent64_s, udata} ptr
151 ext0' <- #{peek struct kevent64_s, ext[0]} ptr
152 ext1' <- #{peek struct kevent64_s, ext[1]} ptr
153 let !ev = KEvent64 ident' (Filter filter') (Flag flags') fflags' data'
158 #{poke struct kevent64_s, ident} ptr (ident ev)
159 #{poke struct kevent64_s, filter} ptr (filter ev)
160 #{poke struct kevent64_s, flags} ptr (flags ev)
161 #{poke struct kevent64_s, fflags} ptr (fflags ev)
162 #{poke struct kevent64_s, data} ptr (data_ ev)
163 #{poke struct kevent64_s, udata} ptr (udata ev)
164 #{poke struct kevent64_s, ext[0]} ptr (ext0 ev)
165 #{poke struct kevent64_s, ext[1]} ptr (ext1 ev)
167 data Event = KEvent {
168 ident :: {-# UNPACK #-} !CUIntPtr
169 , filter :: {-# UNPACK #-} !Filter
170 , flags :: {-# UNPACK #-} !Flag
171 , fflags :: {-# UNPACK #-} !FFlag
172 , data_ :: {-# UNPACK #-} !CIntPtr
173 , udata :: {-# UNPACK #-} !(Ptr ())
176 event :: Fd -> Filter -> Flag -> FFlag -> Event
177 event fd filt flag fflag = KEvent (fromIntegral fd) filt flag fflag 0 nullPtr
179 instance Storable Event where
180 sizeOf _ = #size struct kevent
181 alignment _ = alignment (undefined :: CInt)
184 ident' <- #{peek struct kevent, ident} ptr
185 filter' <- #{peek struct kevent, filter} ptr
186 flags' <- #{peek struct kevent, flags} ptr
187 fflags' <- #{peek struct kevent, fflags} ptr
188 data' <- #{peek struct kevent, data} ptr
189 udata' <- #{peek struct kevent, udata} ptr
190 let !ev = KEvent ident' (Filter filter') (Flag flags') fflags' data'
195 #{poke struct kevent, ident} ptr (ident ev)
196 #{poke struct kevent, filter} ptr (filter ev)
197 #{poke struct kevent, flags} ptr (flags ev)
198 #{poke struct kevent, fflags} ptr (fflags ev)
199 #{poke struct kevent, data} ptr (data_ ev)
200 #{poke struct kevent, udata} ptr (udata ev)
203 newtype FFlag = FFlag Word32
204 deriving (Eq, Show, Storable)
210 newtype Flag = Flag Word16
211 deriving (Eq, Show, Storable)
215 , flagDelete = EV_DELETE
218 newtype Filter = Filter Word16
219 deriving (Bits, Eq, Num, Show, Storable)
221 #{enum Filter, Filter
222 , filterRead = EVFILT_READ
223 , filterWrite = EVFILT_WRITE
226 data TimeSpec = TimeSpec {
227 tv_sec :: {-# UNPACK #-} !CTime
228 , tv_nsec :: {-# UNPACK #-} !CLong
231 instance Storable TimeSpec where
232 sizeOf _ = #size struct timespec
233 alignment _ = alignment (undefined :: CInt)
236 tv_sec' <- #{peek struct timespec, tv_sec} ptr
237 tv_nsec' <- #{peek struct timespec, tv_nsec} ptr
238 let !ts = TimeSpec tv_sec' tv_nsec'
242 #{poke struct timespec, tv_sec} ptr (tv_sec ts)
243 #{poke struct timespec, tv_nsec} ptr (tv_nsec ts)
246 kqueue = QueueFd `fmap` throwErrnoIfMinus1 "kqueue" c_kqueue
248 -- TODO: We cannot retry on EINTR as the timeout would be wrong.
249 -- Perhaps we should just return without calling any callbacks.
250 kevent :: QueueFd -> Ptr Event -> Int -> Ptr Event -> Int -> Ptr TimeSpec
252 kevent k chs chlen evs evlen ts
253 = fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $
254 #if defined(HAVE_KEVENT64)
255 c_kevent64 k chs (fromIntegral chlen) evs (fromIntegral evlen) 0 ts
257 c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
260 withTimeSpec :: TimeSpec -> (Ptr TimeSpec -> IO a) -> IO a
262 if tv_sec ts < 0 then
265 alloca $ \ptr -> poke ptr ts >> f ptr
267 fromTimeout :: Timeout -> TimeSpec
268 fromTimeout Forever = TimeSpec (-1) (-1)
269 fromTimeout (Timeout s) = TimeSpec (toEnum sec) (toEnum nanosec)
275 nanosec = ceiling $ (s - fromIntegral sec) * 1000000000
277 toEvent :: Filter -> E.Event
279 | f == (#const EVFILT_READ) = E.evtRead
280 | f == (#const EVFILT_WRITE) = E.evtWrite
281 | otherwise = error $ "toEvent: unknown filter " ++ show f
283 foreign import ccall unsafe "kqueue"
286 #if defined(HAVE_KEVENT64)
287 foreign import ccall safe "kevent64"
288 c_kevent64 :: QueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt -> CUInt
289 -> Ptr TimeSpec -> IO CInt
290 #elif defined(HAVE_KEVENT)
291 foreign import ccall safe "kevent"
292 c_kevent :: QueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt
293 -> Ptr TimeSpec -> IO CInt
295 #error no kevent system call available!?
298 #endif /* defined(HAVE_KQUEUE) */