2 , ForeignFunctionInterface
3 , GeneralizedNewtypeDeriving
9 module GHC.Event.KQueue
15 import qualified GHC.Event.Internal as E
17 #include "EventConfig.h"
18 #if !defined(HAVE_KQUEUE)
22 new = error "KQueue back end not implemented for this platform"
26 {-# INLINE available #-}
29 import Control.Concurrent.MVar (MVar, newMVar, swapMVar, withMVar)
30 import Control.Monad (when, unless)
31 import Data.Bits (Bits(..))
32 import Data.Word (Word16, Word32)
33 import Foreign.C.Error (throwErrnoIfMinus1)
34 import Foreign.C.Types (CInt, CLong, CTime)
35 import Foreign.Marshal.Alloc (alloca)
36 import Foreign.Ptr (Ptr, nullPtr)
37 import Foreign.Storable (Storable(..))
39 import GHC.Enum (toEnum)
40 import GHC.Err (undefined)
41 import GHC.Num (Num(..))
42 import GHC.Real (ceiling, floor, fromIntegral)
43 import GHC.Show (Show(show))
44 import GHC.Event.Internal (Timeout(..))
45 import System.Posix.Internals (c_close)
46 import System.Posix.Types (Fd(..))
47 import qualified GHC.Event.Array as A
49 #if defined(HAVE_KEVENT64)
50 import Data.Int (Int64)
51 import Data.Word (Word64)
52 import Foreign.C.Types (CUInt)
54 import Foreign.C.Types (CIntPtr, CUIntPtr)
57 #include <sys/types.h>
58 #include <sys/event.h>
61 -- Handle brokenness on some BSD variants, notably OS X up to at least
62 -- 10.6. If NOTE_EOF isn't available, we have no way to receive a
63 -- notification from the kernel when we reach EOF on a plain file.
70 {-# INLINE available #-}
72 ------------------------------------------------------------------------
75 data EventQueue = EventQueue {
76 eqFd :: {-# UNPACK #-} !QueueFd
77 , eqChanges :: {-# UNPACK #-} !(MVar (A.Array Event))
78 , eqEvents :: {-# UNPACK #-} !(A.Array Event)
85 changes <- newMVar changesArr
87 let !be = E.backend poll modifyFd delete (EventQueue qfd changes events)
90 delete :: EventQueue -> IO ()
92 _ <- c_close . fromQueueFd . eqFd $ q
95 modifyFd :: EventQueue -> Fd -> E.Event -> E.Event -> IO ()
96 modifyFd q fd oevt nevt = withMVar (eqChanges q) $ \ch -> do
97 let addChange filt flag = A.snoc ch $ event fd filt flag noteEOF
98 when (oevt `E.eventIs` E.evtRead) $ addChange filterRead flagDelete
99 when (oevt `E.eventIs` E.evtWrite) $ addChange filterWrite flagDelete
100 when (nevt `E.eventIs` E.evtRead) $ addChange filterRead flagAdd
101 when (nevt `E.eventIs` E.evtWrite) $ addChange filterWrite flagAdd
105 -> (Fd -> E.Event -> IO ())
107 poll EventQueue{..} tout f = do
108 changesArr <- A.empty
109 changes <- swapMVar eqChanges changesArr
110 changesLen <- A.length changes
111 len <- A.length eqEvents
112 when (changesLen > len) $ A.ensureCapacity eqEvents (2 * changesLen)
113 n <- A.useAsPtr changes $ \changesPtr chLen ->
114 A.unsafeLoad eqEvents $ \evPtr evCap ->
115 withTimeSpec (fromTimeout tout) $
116 kevent eqFd changesPtr chLen evPtr evCap
119 cap <- A.capacity eqEvents
120 when (n == cap) $ A.ensureCapacity eqEvents (2 * cap)
121 A.forM_ eqEvents $ \e -> f (fromIntegral (ident e)) (toEvent (filter e))
123 ------------------------------------------------------------------------
126 newtype QueueFd = QueueFd {
128 } deriving (Eq, Show)
130 #if defined(HAVE_KEVENT64)
131 data Event = KEvent64 {
132 ident :: {-# UNPACK #-} !Word64
133 , filter :: {-# UNPACK #-} !Filter
134 , flags :: {-# UNPACK #-} !Flag
135 , fflags :: {-# UNPACK #-} !FFlag
136 , data_ :: {-# UNPACK #-} !Int64
137 , udata :: {-# UNPACK #-} !Word64
138 , ext0 :: {-# UNPACK #-} !Word64
139 , ext1 :: {-# UNPACK #-} !Word64
142 event :: Fd -> Filter -> Flag -> FFlag -> Event
143 event fd filt flag fflag = KEvent64 (fromIntegral fd) filt flag fflag 0 0 0 0
145 instance Storable Event where
146 sizeOf _ = #size struct kevent64_s
147 alignment _ = alignment (undefined :: CInt)
150 ident' <- #{peek struct kevent64_s, ident} ptr
151 filter' <- #{peek struct kevent64_s, filter} ptr
152 flags' <- #{peek struct kevent64_s, flags} ptr
153 fflags' <- #{peek struct kevent64_s, fflags} ptr
154 data' <- #{peek struct kevent64_s, data} ptr
155 udata' <- #{peek struct kevent64_s, udata} ptr
156 ext0' <- #{peek struct kevent64_s, ext[0]} ptr
157 ext1' <- #{peek struct kevent64_s, ext[1]} ptr
158 let !ev = KEvent64 ident' (Filter filter') (Flag flags') fflags' data'
163 #{poke struct kevent64_s, ident} ptr (ident ev)
164 #{poke struct kevent64_s, filter} ptr (filter ev)
165 #{poke struct kevent64_s, flags} ptr (flags ev)
166 #{poke struct kevent64_s, fflags} ptr (fflags ev)
167 #{poke struct kevent64_s, data} ptr (data_ ev)
168 #{poke struct kevent64_s, udata} ptr (udata ev)
169 #{poke struct kevent64_s, ext[0]} ptr (ext0 ev)
170 #{poke struct kevent64_s, ext[1]} ptr (ext1 ev)
172 data Event = KEvent {
173 ident :: {-# UNPACK #-} !CUIntPtr
174 , filter :: {-# UNPACK #-} !Filter
175 , flags :: {-# UNPACK #-} !Flag
176 , fflags :: {-# UNPACK #-} !FFlag
177 , data_ :: {-# UNPACK #-} !CIntPtr
178 , udata :: {-# UNPACK #-} !(Ptr ())
181 event :: Fd -> Filter -> Flag -> FFlag -> Event
182 event fd filt flag fflag = KEvent (fromIntegral fd) filt flag fflag 0 nullPtr
184 instance Storable Event where
185 sizeOf _ = #size struct kevent
186 alignment _ = alignment (undefined :: CInt)
189 ident' <- #{peek struct kevent, ident} ptr
190 filter' <- #{peek struct kevent, filter} ptr
191 flags' <- #{peek struct kevent, flags} ptr
192 fflags' <- #{peek struct kevent, fflags} ptr
193 data' <- #{peek struct kevent, data} ptr
194 udata' <- #{peek struct kevent, udata} ptr
195 let !ev = KEvent ident' (Filter filter') (Flag flags') fflags' data'
200 #{poke struct kevent, ident} ptr (ident ev)
201 #{poke struct kevent, filter} ptr (filter ev)
202 #{poke struct kevent, flags} ptr (flags ev)
203 #{poke struct kevent, fflags} ptr (fflags ev)
204 #{poke struct kevent, data} ptr (data_ ev)
205 #{poke struct kevent, udata} ptr (udata ev)
208 newtype FFlag = FFlag Word32
209 deriving (Eq, Show, Storable)
215 newtype Flag = Flag Word16
216 deriving (Eq, Show, Storable)
220 , flagDelete = EV_DELETE
223 newtype Filter = Filter Word16
224 deriving (Bits, Eq, Num, Show, Storable)
226 #{enum Filter, Filter
227 , filterRead = EVFILT_READ
228 , filterWrite = EVFILT_WRITE
231 data TimeSpec = TimeSpec {
232 tv_sec :: {-# UNPACK #-} !CTime
233 , tv_nsec :: {-# UNPACK #-} !CLong
236 instance Storable TimeSpec where
237 sizeOf _ = #size struct timespec
238 alignment _ = alignment (undefined :: CInt)
241 tv_sec' <- #{peek struct timespec, tv_sec} ptr
242 tv_nsec' <- #{peek struct timespec, tv_nsec} ptr
243 let !ts = TimeSpec tv_sec' tv_nsec'
247 #{poke struct timespec, tv_sec} ptr (tv_sec ts)
248 #{poke struct timespec, tv_nsec} ptr (tv_nsec ts)
251 kqueue = QueueFd `fmap` throwErrnoIfMinus1 "kqueue" c_kqueue
253 -- TODO: We cannot retry on EINTR as the timeout would be wrong.
254 -- Perhaps we should just return without calling any callbacks.
255 kevent :: QueueFd -> Ptr Event -> Int -> Ptr Event -> Int -> Ptr TimeSpec
257 kevent k chs chlen evs evlen ts
258 = fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $
259 #if defined(HAVE_KEVENT64)
260 c_kevent64 k chs (fromIntegral chlen) evs (fromIntegral evlen) 0 ts
262 c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
265 withTimeSpec :: TimeSpec -> (Ptr TimeSpec -> IO a) -> IO a
267 if tv_sec ts < 0 then
270 alloca $ \ptr -> poke ptr ts >> f ptr
272 fromTimeout :: Timeout -> TimeSpec
273 fromTimeout Forever = TimeSpec (-1) (-1)
274 fromTimeout (Timeout s) = TimeSpec (toEnum sec) (toEnum nanosec)
280 nanosec = ceiling $ (s - fromIntegral sec) * 1000000000
282 toEvent :: Filter -> E.Event
284 | f == (#const EVFILT_READ) = E.evtRead
285 | f == (#const EVFILT_WRITE) = E.evtWrite
286 | otherwise = error $ "toEvent: unknown filter " ++ show f
288 foreign import ccall unsafe "kqueue"
291 #if defined(HAVE_KEVENT64)
292 foreign import ccall safe "kevent64"
293 c_kevent64 :: QueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt -> CUInt
294 -> Ptr TimeSpec -> IO CInt
295 #elif defined(HAVE_KEVENT)
296 foreign import ccall safe "kevent"
297 c_kevent :: QueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt
298 -> Ptr TimeSpec -> IO CInt
300 #error no kevent system call available!?
303 #endif /* defined(HAVE_KQUEUE) */