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