module GHC.Event.KQueue
(
new
, available
) where
import qualified GHC.Event.Internal as E
import Control.Concurrent.MVar (MVar, newMVar, swapMVar, withMVar)
import Control.Monad (when, unless)
import Data.Bits (Bits(..))
import Data.Word (Word16, Word32)
import Foreign.C.Error (throwErrnoIfMinus1)
import Foreign.C.Types
import Foreign.Marshal.Alloc (alloca)
import Foreign.Ptr (Ptr, nullPtr)
import Foreign.Storable (Storable(..))
import GHC.Base
import GHC.Enum (toEnum)
import GHC.Err (undefined)
import GHC.Num (Num(..))
import GHC.Real (ceiling, floor, 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
available :: Bool
available = True
data EventQueue = EventQueue {
eqFd :: !QueueFd
, eqChanges :: !(MVar (A.Array Event))
, eqEvents :: !(A.Array Event)
}
new :: IO E.Backend
new = do
qfd <- kqueue
changesArr <- A.empty
changes <- newMVar changesArr
events <- A.new 64
let !be = E.backend poll modifyFd delete (EventQueue qfd changes events)
return be
delete :: EventQueue -> IO ()
delete q = do
_ <- c_close . fromQueueFd . eqFd $ q
return ()
modifyFd :: EventQueue -> Fd -> E.Event -> E.Event -> IO ()
modifyFd q fd oevt nevt = withMVar (eqChanges q) $ \ch -> do
let addChange filt flag = A.snoc ch $ event fd filt flag noteEOF
when (oevt `E.eventIs` E.evtRead) $ addChange filterRead flagDelete
when (oevt `E.eventIs` E.evtWrite) $ addChange filterWrite flagDelete
when (nevt `E.eventIs` E.evtRead) $ addChange filterRead flagAdd
when (nevt `E.eventIs` E.evtWrite) $ addChange filterWrite flagAdd
poll :: EventQueue
-> Timeout
-> (Fd -> E.Event -> IO ())
-> IO ()
poll EventQueue{..} tout f = do
changesArr <- A.empty
changes <- swapMVar eqChanges changesArr
changesLen <- A.length changes
len <- A.length eqEvents
when (changesLen > len) $ A.ensureCapacity eqEvents (2 * changesLen)
n <- A.useAsPtr changes $ \changesPtr chLen ->
A.unsafeLoad eqEvents $ \evPtr evCap ->
withTimeSpec (fromTimeout tout) $
kevent eqFd changesPtr chLen evPtr evCap
unless (n == 0) $ do
cap <- A.capacity eqEvents
when (n == cap) $ A.ensureCapacity eqEvents (2 * cap)
A.forM_ eqEvents $ \e -> f (fromIntegral (ident e)) (toEvent (filter e))
newtype QueueFd = QueueFd {
fromQueueFd :: CInt
} deriving (Eq, Show)
data Event = KEvent {
ident :: !CUIntPtr
, filter :: !Filter
, flags :: !Flag
, fflags :: !FFlag
, data_ :: !CIntPtr
, udata :: !(Ptr ())
} deriving Show
event :: Fd -> Filter -> Flag -> FFlag -> Event
event fd filt flag fflag = KEvent (fromIntegral fd) filt flag fflag 0 nullPtr
instance Storable Event where
sizeOf _ = (32)
alignment _ = alignment (undefined :: CInt)
peek ptr = do
ident' <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
filter' <- (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr
flags' <- (\hsc_ptr -> peekByteOff hsc_ptr 10) ptr
fflags' <- (\hsc_ptr -> peekByteOff hsc_ptr 12) ptr
data' <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr
udata' <- (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr
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)
(\hsc_ptr -> pokeByteOff hsc_ptr 8) ptr (filter ev)
(\hsc_ptr -> pokeByteOff hsc_ptr 10) ptr (flags ev)
(\hsc_ptr -> pokeByteOff hsc_ptr 12) ptr (fflags ev)
(\hsc_ptr -> pokeByteOff hsc_ptr 16) ptr (data_ ev)
(\hsc_ptr -> pokeByteOff hsc_ptr 24) ptr (udata ev)
newtype FFlag = FFlag Word32
deriving (Eq, Show, Storable)
noteEOF :: FFlag
noteEOF = FFlag 0
newtype Flag = Flag Word16
deriving (Eq, Show, Storable)
flagAdd :: Flag
flagAdd = Flag 1
flagDelete :: Flag
flagDelete = Flag 2
newtype Filter = Filter Word16
deriving (Bits, Eq, Num, Show, Storable)
filterRead :: Filter
filterRead = Filter (1)
filterWrite :: Filter
filterWrite = Filter (2)
data TimeSpec = TimeSpec {
tv_sec :: !CTime
, tv_nsec :: !CLong
}
instance Storable TimeSpec where
sizeOf _ = (16)
alignment _ = alignment (undefined :: CInt)
peek ptr = do
tv_sec' <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
tv_nsec' <- (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr
let !ts = TimeSpec tv_sec' tv_nsec'
return ts
poke ptr ts = do
(\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr (tv_sec ts)
(\hsc_ptr -> pokeByteOff hsc_ptr 8) ptr (tv_nsec ts)
kqueue :: IO QueueFd
kqueue = QueueFd `fmap` throwErrnoIfMinus1 "kqueue" c_kqueue
kevent :: QueueFd -> Ptr Event -> Int -> Ptr Event -> Int -> Ptr TimeSpec
-> IO Int
kevent k chs chlen evs evlen ts
= fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $
c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
withTimeSpec :: TimeSpec -> (Ptr TimeSpec -> IO a) -> IO a
withTimeSpec ts f =
if tv_sec ts < 0 then
f nullPtr
else
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 :: Int
sec = floor s
nanosec :: Int
nanosec = ceiling $ (s fromIntegral sec) * 1000000000
toEvent :: Filter -> E.Event
toEvent (Filter f)
| f == (1) = E.evtRead
| f == (2) = E.evtWrite
| otherwise = error $ "toEvent: unknown filter " ++ show f
foreign import ccall unsafe "kqueue"
c_kqueue :: IO CInt
foreign import ccall safe "__hscore_kevent"
c_kevent :: QueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt
-> Ptr TimeSpec -> IO CInt