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