KQueue.hsc 9.53 KB
Newer Older
dterei's avatar
dterei committed
1
{-# LANGUAGE Trustworthy #-}
2
3
4
5
6
7
8
{-# LANGUAGE CPP
           , ForeignFunctionInterface
           , GeneralizedNewtypeDeriving
           , NoImplicitPrelude
           , RecordWildCards
           , BangPatterns
  #-}
Simon Marlow's avatar
Simon Marlow committed
9

Ian Lynagh's avatar
Ian Lynagh committed
10
module GHC.Event.KQueue
Simon Marlow's avatar
Simon Marlow committed
11
12
13
14
15
    (
      new
    , available
    ) where

Ian Lynagh's avatar
Ian Lynagh committed
16
import qualified GHC.Event.Internal as E
Simon Marlow's avatar
Simon Marlow committed
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

#include "EventConfig.h"
#if !defined(HAVE_KQUEUE)
import GHC.Base

new :: IO E.Backend
new = error "KQueue back end not implemented for this platform"

available :: Bool
available = False
{-# INLINE available #-}
#else

import Control.Concurrent.MVar (MVar, newMVar, swapMVar, withMVar)
import Control.Monad (when, unless)
import Data.Bits (Bits(..))
import Data.Word (Word16, Word32)
import Foreign.C.Error (throwErrnoIfMinus1)
35
import Foreign.C.Types
Simon Marlow's avatar
Simon Marlow committed
36
37
38
39
40
41
42
43
44
import Foreign.Marshal.Alloc (alloca)
import Foreign.Ptr (Ptr, nullPtr)
import Foreign.Storable (Storable(..))
import GHC.Base
import GHC.Enum (toEnum)
import GHC.Err (undefined)
import GHC.Num (Num(..))
import GHC.Real (ceiling, floor, fromIntegral)
import GHC.Show (Show(show))
Ian Lynagh's avatar
Ian Lynagh committed
45
import GHC.Event.Internal (Timeout(..))
Simon Marlow's avatar
Simon Marlow committed
46
47
import System.Posix.Internals (c_close)
import System.Posix.Types (Fd(..))
Ian Lynagh's avatar
Ian Lynagh committed
48
import qualified GHC.Event.Array as A
Simon Marlow's avatar
Simon Marlow committed
49
50
51
52

#if defined(HAVE_KEVENT64)
import Data.Int (Int64)
import Data.Word (Word64)
iquiw's avatar
iquiw committed
53
54
#elif defined(netbsd_HOST_OS)
import Data.Int (Int64)
Simon Marlow's avatar
Simon Marlow committed
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
#endif

#include <sys/types.h>
#include <sys/event.h>
#include <sys/time.h>

-- Handle brokenness on some BSD variants, notably OS X up to at least
-- 10.6.  If NOTE_EOF isn't available, we have no way to receive a
-- notification from the kernel when we reach EOF on a plain file.
#ifndef NOTE_EOF
# define NOTE_EOF 0
#endif

available :: Bool
available = True
{-# INLINE available #-}

------------------------------------------------------------------------
-- Exported interface

data EventQueue = EventQueue {
      eqFd       :: {-# UNPACK #-} !QueueFd
    , eqChanges  :: {-# UNPACK #-} !(MVar (A.Array Event))
    , eqEvents   :: {-# UNPACK #-} !(A.Array Event)
    }

new :: IO E.Backend
new = do
  qfd <- kqueue
  changesArr <- A.empty
  changes <- newMVar changesArr 
  events <- A.new 64
  let !be = E.backend poll modifyFd delete (EventQueue qfd changes events)
  return be

delete :: EventQueue -> IO ()
delete q = do
  _ <- c_close . fromQueueFd . eqFd $ q
  return ()

modifyFd :: EventQueue -> Fd -> E.Event -> E.Event -> IO ()
modifyFd q fd oevt nevt = withMVar (eqChanges q) $ \ch -> do
  let addChange filt flag = A.snoc ch $ event fd filt flag noteEOF
  when (oevt `E.eventIs` E.evtRead)  $ addChange filterRead flagDelete
  when (oevt `E.eventIs` E.evtWrite) $ addChange filterWrite flagDelete
  when (nevt `E.eventIs` E.evtRead)  $ addChange filterRead flagAdd
  when (nevt `E.eventIs` E.evtWrite) $ addChange filterWrite flagAdd

poll :: EventQueue
     -> Timeout
     -> (Fd -> E.Event -> IO ())
     -> IO ()
poll EventQueue{..} tout f = do
    changesArr <- A.empty
    changes <- swapMVar eqChanges changesArr
    changesLen <- A.length changes
    len <- A.length eqEvents
    when (changesLen > len) $ A.ensureCapacity eqEvents (2 * changesLen)
    n <- A.useAsPtr changes $ \changesPtr chLen ->
           A.unsafeLoad eqEvents $ \evPtr evCap ->
             withTimeSpec (fromTimeout tout) $
               kevent eqFd changesPtr chLen evPtr evCap

    unless (n == 0) $ do
        cap <- A.capacity eqEvents
        when (n == cap) $ A.ensureCapacity eqEvents (2 * cap)
        A.forM_ eqEvents $ \e -> f (fromIntegral (ident e)) (toEvent (filter e))

------------------------------------------------------------------------
-- FFI binding

newtype QueueFd = QueueFd {
      fromQueueFd :: CInt
    } deriving (Eq, Show)

#if defined(HAVE_KEVENT64)
data Event = KEvent64 {
      ident  :: {-# UNPACK #-} !Word64
    , filter :: {-# UNPACK #-} !Filter
    , flags  :: {-# UNPACK #-} !Flag
    , fflags :: {-# UNPACK #-} !FFlag
    , data_  :: {-# UNPACK #-} !Int64
    , udata  :: {-# UNPACK #-} !Word64
    , ext0   :: {-# UNPACK #-} !Word64
    , ext1   :: {-# UNPACK #-} !Word64
    } deriving Show

event :: Fd -> Filter -> Flag -> FFlag -> Event
event fd filt flag fflag = KEvent64 (fromIntegral fd) filt flag fflag 0 0 0 0

instance Storable Event where
    sizeOf _ = #size struct kevent64_s
    alignment _ = alignment (undefined :: CInt)

    peek ptr = do
        ident'  <- #{peek struct kevent64_s, ident} ptr
        filter' <- #{peek struct kevent64_s, filter} ptr
        flags'  <- #{peek struct kevent64_s, flags} ptr
        fflags' <- #{peek struct kevent64_s, fflags} ptr
        data'   <- #{peek struct kevent64_s, data} ptr
        udata'  <- #{peek struct kevent64_s, udata} ptr
        ext0'   <- #{peek struct kevent64_s, ext[0]} ptr
        ext1'   <- #{peek struct kevent64_s, ext[1]} ptr
        let !ev = KEvent64 ident' (Filter filter') (Flag flags') fflags' data'
                           udata' ext0' ext1'
        return ev

    poke ptr ev = do
        #{poke struct kevent64_s, ident} ptr (ident ev)
        #{poke struct kevent64_s, filter} ptr (filter ev)
        #{poke struct kevent64_s, flags} ptr (flags ev)
        #{poke struct kevent64_s, fflags} ptr (fflags ev)
        #{poke struct kevent64_s, data} ptr (data_ ev)
        #{poke struct kevent64_s, udata} ptr (udata ev)
        #{poke struct kevent64_s, ext[0]} ptr (ext0 ev)
        #{poke struct kevent64_s, ext[1]} ptr (ext1 ev)
#else
data Event = KEvent {
      ident  :: {-# UNPACK #-} !CUIntPtr
    , filter :: {-# UNPACK #-} !Filter
    , flags  :: {-# UNPACK #-} !Flag
    , fflags :: {-# UNPACK #-} !FFlag
iquiw's avatar
iquiw committed
177
178
179
#ifdef netbsd_HOST_OS
    , data_  :: {-# UNPACK #-} !Int64
#else
Simon Marlow's avatar
Simon Marlow committed
180
    , data_  :: {-# UNPACK #-} !CIntPtr
iquiw's avatar
iquiw committed
181
#endif
Simon Marlow's avatar
Simon Marlow committed
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
214
215
216
217
218
    , udata  :: {-# UNPACK #-} !(Ptr ())
    } deriving Show

event :: Fd -> Filter -> Flag -> FFlag -> Event
event fd filt flag fflag = KEvent (fromIntegral fd) filt flag fflag 0 nullPtr

instance Storable Event where
    sizeOf _ = #size struct kevent
    alignment _ = alignment (undefined :: CInt)

    peek ptr = do
        ident'  <- #{peek struct kevent, ident} ptr
        filter' <- #{peek struct kevent, filter} ptr
        flags'  <- #{peek struct kevent, flags} ptr
        fflags' <- #{peek struct kevent, fflags} ptr
        data'   <- #{peek struct kevent, data} ptr
        udata'  <- #{peek struct kevent, udata} ptr
        let !ev = KEvent ident' (Filter filter') (Flag flags') fflags' data'
                         udata'
        return ev

    poke ptr ev = do
        #{poke struct kevent, ident} ptr (ident ev)
        #{poke struct kevent, filter} ptr (filter ev)
        #{poke struct kevent, flags} ptr (flags ev)
        #{poke struct kevent, fflags} ptr (fflags ev)
        #{poke struct kevent, data} ptr (data_ ev)
        #{poke struct kevent, udata} ptr (udata ev)
#endif

newtype FFlag = FFlag Word32
    deriving (Eq, Show, Storable)

#{enum FFlag, FFlag
 , noteEOF = NOTE_EOF
 }

iquiw's avatar
iquiw committed
219
220
221
#if SIZEOF_KEV_FLAGS == 4 /* kevent.flag: uint32_t or uint16_t. */
newtype Flag = Flag Word32
#else
Simon Marlow's avatar
Simon Marlow committed
222
newtype Flag = Flag Word16
iquiw's avatar
iquiw committed
223
#endif
Simon Marlow's avatar
Simon Marlow committed
224
225
226
227
228
229
230
    deriving (Eq, Show, Storable)

#{enum Flag, Flag
 , flagAdd     = EV_ADD
 , flagDelete  = EV_DELETE
 }

iquiw's avatar
iquiw committed
231
232
233
#if SIZEOF_KEV_FILTER == 4 /*kevent.filter: uint32_t or uint16_t. */
newtype Filter = Filter Word32
#else
Simon Marlow's avatar
Simon Marlow committed
234
newtype Filter = Filter Word16
iquiw's avatar
iquiw committed
235
#endif
Simon Marlow's avatar
Simon Marlow committed
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
    deriving (Bits, Eq, Num, Show, Storable)

#{enum Filter, Filter
 , filterRead   = EVFILT_READ
 , filterWrite  = EVFILT_WRITE
 }

data TimeSpec = TimeSpec {
      tv_sec  :: {-# UNPACK #-} !CTime
    , tv_nsec :: {-# UNPACK #-} !CLong
    }

instance Storable TimeSpec where
    sizeOf _ = #size struct timespec
    alignment _ = alignment (undefined :: CInt)

    peek ptr = do
        tv_sec'  <- #{peek struct timespec, tv_sec} ptr
        tv_nsec' <- #{peek struct timespec, tv_nsec} ptr
        let !ts = TimeSpec tv_sec' tv_nsec'
        return ts

    poke ptr ts = do
        #{poke struct timespec, tv_sec} ptr (tv_sec ts)
        #{poke struct timespec, tv_nsec} ptr (tv_nsec ts)

kqueue :: IO QueueFd
kqueue = QueueFd `fmap` throwErrnoIfMinus1 "kqueue" c_kqueue

-- TODO: We cannot retry on EINTR as the timeout would be wrong.
-- Perhaps we should just return without calling any callbacks.
kevent :: QueueFd -> Ptr Event -> Int -> Ptr Event -> Int -> Ptr TimeSpec
       -> IO Int
kevent k chs chlen evs evlen ts
    = fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $
#if defined(HAVE_KEVENT64)
      c_kevent64 k chs (fromIntegral chlen) evs (fromIntegral evlen) 0 ts
#else
      c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
#endif

withTimeSpec :: TimeSpec -> (Ptr TimeSpec -> IO a) -> IO a
withTimeSpec ts f =
    if tv_sec ts < 0 then
        f nullPtr
      else
        alloca $ \ptr -> poke ptr ts >> f ptr

fromTimeout :: Timeout -> TimeSpec
fromTimeout Forever     = TimeSpec (-1) (-1)
fromTimeout (Timeout s) = TimeSpec (toEnum sec) (toEnum nanosec)
  where
    sec :: Int
    sec     = floor s

    nanosec :: Int
    nanosec = ceiling $ (s - fromIntegral sec) * 1000000000

toEvent :: Filter -> E.Event
toEvent (Filter f)
    | f == (#const EVFILT_READ) = E.evtRead
    | f == (#const EVFILT_WRITE) = E.evtWrite
bos's avatar
bos committed
298
    | otherwise = error $ "toEvent: unknown filter " ++ show f
Simon Marlow's avatar
Simon Marlow committed
299
300
301
302
303
304
305
306
307

foreign import ccall unsafe "kqueue"
    c_kqueue :: IO CInt

#if defined(HAVE_KEVENT64)
foreign import ccall safe "kevent64"
    c_kevent64 :: QueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt -> CUInt
               -> Ptr TimeSpec -> IO CInt
#elif defined(HAVE_KEVENT)
308
foreign import capi safe "sys/event.h kevent"
Simon Marlow's avatar
Simon Marlow committed
309
310
311
312
313
314
315
    c_kevent :: QueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt
             -> Ptr TimeSpec -> IO CInt
#else
#error no kevent system call available!?
#endif

#endif /* defined(HAVE_KQUEUE) */
dterei's avatar
dterei committed
316