Fix build on OS X
[packages/base.git] / GHC / Event / KQueue.hsc
1 {-# LANGUAGE Trustworthy #-}
2 {-# LANGUAGE CPP
3            , ForeignFunctionInterface
4            , CApiFFI
5            , GeneralizedNewtypeDeriving
6            , NoImplicitPrelude
7            , RecordWildCards
8            , BangPatterns
9   #-}
10
11 module GHC.Event.KQueue
12     (
13       new
14     , available
15     ) where
16
17 import qualified GHC.Event.Internal as E
18
19 #include "EventConfig.h"
20 #if !defined(HAVE_KQUEUE)
21 import GHC.Base
22
23 new :: IO E.Backend
24 new = error "KQueue back end not implemented for this platform"
25
26 available :: Bool
27 available = False
28 {-# INLINE available #-}
29 #else
30
31 import Control.Monad (when)
32 import Data.Bits (Bits(..))
33 import Data.Maybe (Maybe(..))
34 import Data.Monoid (Monoid(..))
35 import Data.Word (Word16, Word32)
36 import Foreign.C.Error (throwErrnoIfMinus1, eINTR, eINVAL,
37                         eNOTSUP, getErrno, throwErrno)
38 import Foreign.C.Types
39 import Foreign.Marshal.Alloc (alloca)
40 import Foreign.Ptr (Ptr, nullPtr)
41 import Foreign.Storable (Storable(..))
42 import GHC.Base
43 import GHC.Enum (toEnum)
44 import GHC.Num (Num(..))
45 import GHC.Real (ceiling, floor, fromIntegral)
46 import GHC.Show (Show(show))
47 import GHC.Event.Internal (Timeout(..))
48 import System.Posix.Internals (c_close)
49 import System.Posix.Types (Fd(..))
50 import qualified GHC.Event.Array as A
51
52 #if defined(netbsd_HOST_OS)
53 import Data.Int (Int64)
54 #endif
55
56 #include <sys/types.h>
57 #include <sys/event.h>
58 #include <sys/time.h>
59
60 -- Handle brokenness on some BSD variants, notably OS X up to at least
61 -- 10.6.  If NOTE_EOF isn't available, we have no way to receive a
62 -- notification from the kernel when we reach EOF on a plain file.
63 #ifndef NOTE_EOF
64 # define NOTE_EOF 0
65 #endif
66
67 available :: Bool
68 available = True
69 {-# INLINE available #-}
70
71 ------------------------------------------------------------------------
72 -- Exported interface
73
74 data KQueue = KQueue {
75       kqueueFd     :: {-# UNPACK #-} !KQueueFd
76     , kqueueEvents :: {-# UNPACK #-} !(A.Array Event)
77     }
78
79 new :: IO E.Backend
80 new = do
81   kqfd <- kqueue
82   events <- A.new 64
83   let !be = E.backend poll modifyFd modifyFdOnce delete (KQueue kqfd events)
84   return be
85
86 delete :: KQueue -> IO ()
87 delete kq = do
88   _ <- c_close . fromKQueueFd . kqueueFd $ kq
89   return ()
90
91 modifyFd :: KQueue -> Fd -> E.Event -> E.Event -> IO Bool
92 modifyFd kq fd oevt nevt
93   | nevt == mempty = do
94       let !ev = event fd (toFilter oevt) flagDelete noteEOF
95       kqueueControl (kqueueFd kq) ev
96   | otherwise      = do
97       let !ev = event fd (toFilter nevt) flagAdd noteEOF
98       kqueueControl (kqueueFd kq) ev
99
100 toFilter :: E.Event -> Filter
101 toFilter evt
102   | evt `E.eventIs` E.evtRead = filterRead
103   | otherwise                 = filterWrite
104
105 modifyFdOnce :: KQueue -> Fd -> E.Event -> IO Bool
106 modifyFdOnce kq fd evt = do
107     let !ev = event fd (toFilter evt) (flagAdd .|. flagOneshot) noteEOF
108     kqueueControl (kqueueFd kq) ev
109
110 poll :: KQueue
111      -> Maybe Timeout
112      -> (Fd -> E.Event -> IO ())
113      -> IO Int
114 poll kq mtimeout f = do
115     let events = kqueueEvents kq
116         fd = kqueueFd kq
117
118     n <- A.unsafeLoad events $ \es cap -> case mtimeout of
119       Just timeout -> kqueueWait fd es cap $ fromTimeout timeout
120       Nothing      -> kqueueWaitNonBlock fd es cap
121
122     when (n > 0) $ do
123         A.forM_ events $ \e -> f (fromIntegral (ident e)) (toEvent (filter e))
124         cap <- A.capacity events
125         when (n == cap) $ A.ensureCapacity events (2 * cap)
126     return n
127 ------------------------------------------------------------------------
128 -- FFI binding
129
130 newtype KQueueFd = KQueueFd {
131       fromKQueueFd :: CInt
132     } deriving (Eq, Show)
133
134 data Event = KEvent {
135       ident  :: {-# UNPACK #-} !CUIntPtr
136     , filter :: {-# UNPACK #-} !Filter
137     , flags  :: {-# UNPACK #-} !Flag
138     , fflags :: {-# UNPACK #-} !FFlag
139 #ifdef netbsd_HOST_OS
140     , data_  :: {-# UNPACK #-} !Int64
141 #else
142     , data_  :: {-# UNPACK #-} !CIntPtr
143 #endif
144     , udata  :: {-# UNPACK #-} !(Ptr ())
145     } deriving Show
146
147 event :: Fd -> Filter -> Flag -> FFlag -> Event
148 event fd filt flag fflag = KEvent (fromIntegral fd) filt flag fflag 0 nullPtr
149
150 instance Storable Event where
151     sizeOf _ = #size struct kevent
152     alignment _ = alignment (undefined :: CInt)
153
154     peek ptr = do
155         ident'  <- #{peek struct kevent, ident} ptr
156         filter' <- #{peek struct kevent, filter} ptr
157         flags'  <- #{peek struct kevent, flags} ptr
158         fflags' <- #{peek struct kevent, fflags} ptr
159         data'   <- #{peek struct kevent, data} ptr
160         udata'  <- #{peek struct kevent, udata} ptr
161         let !ev = KEvent ident' (Filter filter') (Flag flags') fflags' data'
162                          udata'
163         return ev
164
165     poke ptr ev = do
166         #{poke struct kevent, ident} ptr (ident ev)
167         #{poke struct kevent, filter} ptr (filter ev)
168         #{poke struct kevent, flags} ptr (flags ev)
169         #{poke struct kevent, fflags} ptr (fflags ev)
170         #{poke struct kevent, data} ptr (data_ ev)
171         #{poke struct kevent, udata} ptr (udata ev)
172
173 newtype FFlag = FFlag Word32
174     deriving (Eq, Show, Storable)
175
176 #{enum FFlag, FFlag
177  , noteEOF = NOTE_EOF
178  }
179
180 #if SIZEOF_KEV_FLAGS == 4 /* kevent.flag: uint32_t or uint16_t. */
181 newtype Flag = Flag Word32
182 #else
183 newtype Flag = Flag Word16
184 #endif
185     deriving (Bits, Eq, Num, Show, Storable)
186
187 #{enum Flag, Flag
188  , flagAdd     = EV_ADD
189  , flagDelete  = EV_DELETE
190  , flagOneshot = EV_ONESHOT
191  }
192
193 #if SIZEOF_KEV_FILTER == 4 /*kevent.filter: uint32_t or uint16_t. */
194 newtype Filter = Filter Word32
195 #else
196 newtype Filter = Filter Word16
197 #endif
198     deriving (Bits, Eq, Num, Show, Storable)
199
200 filterRead :: Filter
201 filterRead = Filter (#const EVFILT_READ)
202 filterWrite :: Filter
203 filterWrite  = Filter (#const EVFILT_WRITE)
204
205 data TimeSpec = TimeSpec {
206       tv_sec  :: {-# UNPACK #-} !CTime
207     , tv_nsec :: {-# UNPACK #-} !CLong
208     }
209
210 instance Storable TimeSpec where
211     sizeOf _ = #size struct timespec
212     alignment _ = alignment (undefined :: CInt)
213
214     peek ptr = do
215         tv_sec'  <- #{peek struct timespec, tv_sec} ptr
216         tv_nsec' <- #{peek struct timespec, tv_nsec} ptr
217         let !ts = TimeSpec tv_sec' tv_nsec'
218         return ts
219
220     poke ptr ts = do
221         #{poke struct timespec, tv_sec} ptr (tv_sec ts)
222         #{poke struct timespec, tv_nsec} ptr (tv_nsec ts)
223
224 kqueue :: IO KQueueFd
225 kqueue = KQueueFd `fmap` throwErrnoIfMinus1 "kqueue" c_kqueue
226
227 kqueueControl :: KQueueFd -> Event -> IO Bool
228 kqueueControl kfd ev =
229     withTimeSpec (TimeSpec 0 0) $ \tp ->
230         withEvent ev $ \evp -> do
231             res <- kevent False kfd evp 1 nullPtr 0 tp
232             if res == -1
233               then do
234                err <- getErrno
235                case err of
236                  _ | err == eINTR  -> return True
237                  _ | err == eINVAL -> return False
238                  _ | err == eNOTSUP -> return False
239                  _                 -> throwErrno "kevent"
240               else return True
241
242 kqueueWait :: KQueueFd -> Ptr Event -> Int -> TimeSpec -> IO Int
243 kqueueWait fd es cap tm =
244     fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $
245     withTimeSpec tm $ kevent True fd nullPtr 0 es cap
246
247 kqueueWaitNonBlock :: KQueueFd -> Ptr Event -> Int -> IO Int
248 kqueueWaitNonBlock fd es cap =
249     fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $
250     withTimeSpec (TimeSpec 0 0) $ kevent False fd nullPtr 0 es cap
251
252 -- TODO: We cannot retry on EINTR as the timeout would be wrong.
253 -- Perhaps we should just return without calling any callbacks.
254 kevent :: Bool -> KQueueFd -> Ptr Event -> Int -> Ptr Event -> Int -> Ptr TimeSpec
255        -> IO CInt
256 kevent safe k chs chlen evs evlen ts
257   | safe      = c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
258   | otherwise = c_kevent_unsafe k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
259
260 withEvent :: Event -> (Ptr Event -> IO a) -> IO a
261 withEvent ev f = alloca $ \ptr -> poke ptr ev >> f ptr
262
263 withTimeSpec :: TimeSpec -> (Ptr TimeSpec -> IO a) -> IO a
264 withTimeSpec ts f
265   | tv_sec ts < 0 = f nullPtr
266   | otherwise     = alloca $ \ptr -> poke ptr ts >> f ptr
267
268 fromTimeout :: Timeout -> TimeSpec
269 fromTimeout Forever     = TimeSpec (-1) (-1)
270 fromTimeout (Timeout s) = TimeSpec (toEnum sec) (toEnum nanosec)
271   where
272     sec :: Int
273     sec     = floor s
274
275     nanosec :: Int
276     nanosec = ceiling $ (s - fromIntegral sec) * 1000000000
277
278 toEvent :: Filter -> E.Event
279 toEvent (Filter f)
280   | f == (#const EVFILT_READ) = E.evtRead
281   | f == (#const EVFILT_WRITE) = E.evtWrite
282   | otherwise = error $ "toEvent: unknown filter " ++ show f
283
284 foreign import ccall unsafe "kqueue"
285     c_kqueue :: IO CInt
286
287 #if defined(HAVE_KEVENT)
288 foreign import capi safe "sys/event.h kevent"
289     c_kevent :: KQueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt
290              -> Ptr TimeSpec -> IO CInt
291
292 foreign import ccall unsafe "kevent"
293     c_kevent_unsafe :: KQueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt
294                     -> Ptr TimeSpec -> IO CInt
295 #else
296 #error no kevent system call available!?
297 #endif
298
299 #endif /* defined(HAVE_KQUEUE) */