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