{-# LINE 1 "libraries/base/GHC/Event/KQueue.hsc" #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CApiFFI
, GeneralizedNewtypeDeriving
, NoImplicitPrelude
, RecordWildCards
, BangPatterns
#-}
module GHC.Event.KQueue
(
new
, available
) where
import qualified GHC.Event.Internal as E
{-# LINE 28 "libraries/base/GHC/Event/KQueue.hsc" #-}
import Data.Bits (Bits(..), FiniteBits(..))
import Data.Int
import Data.Maybe ( catMaybes )
import Data.Word (Word16, Word32)
import Foreign.C.Error (throwErrnoIfMinus1, eINTR, eINVAL,
eNOTSUP, getErrno, throwErrno)
import Foreign.C.Types
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Array (withArrayLen)
import Foreign.Ptr (Ptr, nullPtr)
import Foreign.Storable (Storable(..))
import GHC.Base
import GHC.Enum (toEnum)
import GHC.Num (Num(..))
import GHC.Real (quotRem, fromIntegral)
import GHC.Show (Show(show))
import GHC.Event.Internal (Timeout(..))
import System.Posix.Internals (c_close)
import System.Posix.Types (Fd(..))
import qualified GHC.Event.Array as A
{-# LINE 53 "libraries/base/GHC/Event/KQueue.hsc" #-}
{-# LINE 64 "libraries/base/GHC/Event/KQueue.hsc" #-}
available :: Bool
available = True
{-# INLINE available #-}
data KQueue = KQueue {
kqueueFd :: {-# UNPACK #-} !KQueueFd
, kqueueEvents :: {-# UNPACK #-} !(A.Array Event)
}
new :: IO E.Backend
new = do
kqfd <- kqueue
events <- A.new 64
let !be = E.backend poll modifyFd modifyFdOnce delete (KQueue kqfd events)
return be
delete :: KQueue -> IO ()
delete kq = do
_ <- c_close . fromKQueueFd . kqueueFd $ kq
return ()
modifyFd :: KQueue -> Fd -> E.Event -> E.Event -> IO Bool
modifyFd kq fd oevt nevt = kqueueControl (kqueueFd kq) evs
where
evs
| nevt == mempty = toEvents fd (toFilter oevt) flagDelete noteEOF
| otherwise = toEvents fd (toFilter nevt) flagAdd noteEOF
toFilter :: E.Event -> [Filter]
toFilter e = catMaybes [ check E.evtRead filterRead, check E.evtWrite filterWrite ]
where
check e' f = if e `E.eventIs` e' then Just f else Nothing
modifyFdOnce :: KQueue -> Fd -> E.Event -> IO Bool
modifyFdOnce kq fd evt =
kqueueControl (kqueueFd kq) (toEvents fd (toFilter evt) (flagAdd .|. flagOneshot) noteEOF)
poll :: KQueue
-> Maybe Timeout
-> (Fd -> E.Event -> IO ())
-> IO Int
poll kq mtimeout f = do
let events = kqueueEvents kq
fd = kqueueFd kq
n <- A.unsafeLoad events $ \es cap -> case mtimeout of
Just timeout -> kqueueWait fd es cap $ fromTimeout timeout
Nothing -> kqueueWaitNonBlock fd es cap
when (n > 0) $ do
A.forM_ events $ \e -> f (fromIntegral (ident e)) (toEvent (filter e))
cap <- A.capacity events
when (n == cap) $ A.ensureCapacity events (2 * cap)
return n
newtype KQueueFd = KQueueFd {
fromKQueueFd :: CInt
} deriving (Eq, Show)
data Event = KEvent {
ident :: {-# UNPACK #-} !CUIntPtr
, filter :: {-# UNPACK #-} !Filter
, flags :: {-# UNPACK #-} !Flag
, fflags :: {-# UNPACK #-} !FFlag
{-# LINE 137 "libraries/base/GHC/Event/KQueue.hsc" #-}
, data_ :: {-# UNPACK #-} !CIntPtr
{-# LINE 139 "libraries/base/GHC/Event/KQueue.hsc" #-}
, udata :: {-# UNPACK #-} !(Ptr ())
} deriving Show
toEvents :: Fd -> [Filter] -> Flag -> FFlag -> [Event]
toEvents fd flts flag fflag = map (\filt -> KEvent (fromIntegral fd) filt flag fflag 0 nullPtr) flts
instance Storable Event where
sizeOf _ = (32)
{-# LINE 148 "libraries/base/GHC/Event/KQueue.hsc" #-}
alignment _ = alignment (undefined :: CInt)
peek ptr = do
ident' <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
{-# LINE 152 "libraries/base/GHC/Event/KQueue.hsc" #-}
filter' <- (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr
{-# LINE 153 "libraries/base/GHC/Event/KQueue.hsc" #-}
flags' <- (\hsc_ptr -> peekByteOff hsc_ptr 10) ptr
{-# LINE 154 "libraries/base/GHC/Event/KQueue.hsc" #-}
fflags' <- (\hsc_ptr -> peekByteOff hsc_ptr 12) ptr
{-# LINE 155 "libraries/base/GHC/Event/KQueue.hsc" #-}
data' <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr
{-# LINE 156 "libraries/base/GHC/Event/KQueue.hsc" #-}
udata' <- (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr
{-# LINE 157 "libraries/base/GHC/Event/KQueue.hsc" #-}
let !ev = KEvent ident' (Filter filter') (Flag flags') fflags' data'
udata'
return ev
poke ptr ev = do
(\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr (ident ev)
{-# LINE 163 "libraries/base/GHC/Event/KQueue.hsc" #-}
(\hsc_ptr -> pokeByteOff hsc_ptr 8) ptr (filter ev)
{-# LINE 164 "libraries/base/GHC/Event/KQueue.hsc" #-}
(\hsc_ptr -> pokeByteOff hsc_ptr 10) ptr (flags ev)
{-# LINE 165 "libraries/base/GHC/Event/KQueue.hsc" #-}
(\hsc_ptr -> pokeByteOff hsc_ptr 12) ptr (fflags ev)
{-# LINE 166 "libraries/base/GHC/Event/KQueue.hsc" #-}
(\hsc_ptr -> pokeByteOff hsc_ptr 16) ptr (data_ ev)
{-# LINE 167 "libraries/base/GHC/Event/KQueue.hsc" #-}
(\hsc_ptr -> pokeByteOff hsc_ptr 24) ptr (udata ev)
{-# LINE 168 "libraries/base/GHC/Event/KQueue.hsc" #-}
newtype FFlag = FFlag Word32
deriving (Eq, Show, Storable)
noteEOF :: FFlag
noteEOF = FFlag 0
{-# LINE 175 "libraries/base/GHC/Event/KQueue.hsc" #-}
{-# LINE 179 "libraries/base/GHC/Event/KQueue.hsc" #-}
newtype Flag = Flag Word16
{-# LINE 181 "libraries/base/GHC/Event/KQueue.hsc" #-}
deriving (Bits, FiniteBits, Eq, Num, Show, Storable)
flagAdd :: Flag
flagAdd = Flag 1
flagDelete :: Flag
flagDelete = Flag 2
flagOneshot :: Flag
flagOneshot = Flag 16
{-# LINE 188 "libraries/base/GHC/Event/KQueue.hsc" #-}
{-# LINE 192 "libraries/base/GHC/Event/KQueue.hsc" #-}
newtype Filter = Filter Int16
{-# LINE 194 "libraries/base/GHC/Event/KQueue.hsc" #-}
deriving (Eq, Num, Show, Storable)
filterRead :: Filter
filterRead = Filter (-1)
{-# LINE 198 "libraries/base/GHC/Event/KQueue.hsc" #-}
filterWrite :: Filter
filterWrite = Filter (-2)
{-# LINE 200 "libraries/base/GHC/Event/KQueue.hsc" #-}
data TimeSpec = TimeSpec {
tv_sec :: {-# UNPACK #-} !CTime
, tv_nsec :: {-# UNPACK #-} !CLong
}
instance Storable TimeSpec where
sizeOf _ = (16)
{-# LINE 209 "libraries/base/GHC/Event/KQueue.hsc" #-}
alignment _ = alignment (undefined :: CInt)
peek ptr = do
tv_sec' <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
{-# LINE 213 "libraries/base/GHC/Event/KQueue.hsc" #-}
tv_nsec' <- (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr
{-# LINE 214 "libraries/base/GHC/Event/KQueue.hsc" #-}
let !ts = TimeSpec tv_sec' tv_nsec'
return ts
poke ptr ts = do
(\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr (tv_sec ts)
{-# LINE 219 "libraries/base/GHC/Event/KQueue.hsc" #-}
(\hsc_ptr -> pokeByteOff hsc_ptr 8) ptr (tv_nsec ts)
{-# LINE 220 "libraries/base/GHC/Event/KQueue.hsc" #-}
kqueue :: IO KQueueFd
kqueue = KQueueFd `fmap` throwErrnoIfMinus1 "kqueue" c_kqueue
kqueueControl :: KQueueFd -> [Event] -> IO Bool
kqueueControl kfd evts =
withTimeSpec (TimeSpec 0 0) $ \tp ->
withArrayLen evts $ \evlen evp -> do
res <- kevent False kfd evp evlen nullPtr 0 tp
if res == -1
then do
err <- getErrno
case err of
_ | err == eINTR -> return True
_ | err == eINVAL -> return False
_ | err == eNOTSUP -> return False
_ -> throwErrno "kevent"
else return True
kqueueWait :: KQueueFd -> Ptr Event -> Int -> TimeSpec -> IO Int
kqueueWait fd es cap tm =
fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $
withTimeSpec tm $ kevent True fd nullPtr 0 es cap
kqueueWaitNonBlock :: KQueueFd -> Ptr Event -> Int -> IO Int
kqueueWaitNonBlock fd es cap =
fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $
withTimeSpec (TimeSpec 0 0) $ kevent False fd nullPtr 0 es cap
kevent :: Bool -> KQueueFd -> Ptr Event -> Int -> Ptr Event -> Int -> Ptr TimeSpec
-> IO CInt
kevent safe k chs chlen evs evlen ts
| safe = c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
| otherwise = c_kevent_unsafe k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
withTimeSpec :: TimeSpec -> (Ptr TimeSpec -> IO a) -> IO a
withTimeSpec ts f
| tv_sec ts < 0 = f nullPtr
| otherwise = 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, nanosec) = s `quotRem` 1000000000
nanosec', sec' :: Int
sec' = fromIntegral sec
nanosec' = fromIntegral nanosec
toEvent :: Filter -> E.Event
toEvent (Filter f)
| f == (-1) = E.evtRead
{-# LINE 275 "libraries/base/GHC/Event/KQueue.hsc" #-}
| f == (-2) = E.evtWrite
{-# LINE 276 "libraries/base/GHC/Event/KQueue.hsc" #-}
| otherwise = errorWithoutStackTrace $ "toEvent: unknown filter " ++ show f
foreign import ccall unsafe "kqueue"
c_kqueue :: IO CInt
{-# LINE 282 "libraries/base/GHC/Event/KQueue.hsc" #-}
foreign import capi safe "sys/event.h kevent"
c_kevent :: KQueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt
-> Ptr TimeSpec -> IO CInt
foreign import ccall unsafe "kevent"
c_kevent_unsafe :: KQueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt
-> Ptr TimeSpec -> IO CInt
{-# LINE 292 "libraries/base/GHC/Event/KQueue.hsc" #-}
{-# LINE 294 "libraries/base/GHC/Event/KQueue.hsc" #-}