Commit 4a807620 authored by tibbe's avatar tibbe

Merge the new parallel I/O manager

parents 0419c957 aceb3e89
......@@ -99,6 +99,7 @@ module GHC.Conc
#endif
, ensureIOManagerIsRunning
, ioManagerCapabilitiesChanged
#ifdef mingw32_HOST_OS
, ConsoleEvent(..)
......
......@@ -32,6 +32,7 @@
-- #not-home
module GHC.Conc.IO
( ensureIOManagerIsRunning
, ioManagerCapabilitiesChanged
-- * Waiting
, threadDelay
......@@ -78,6 +79,13 @@ ensureIOManagerIsRunning = Event.ensureIOManagerIsRunning
ensureIOManagerIsRunning = Windows.ensureIOManagerIsRunning
#endif
ioManagerCapabilitiesChanged :: IO ()
#ifndef mingw32_HOST_OS
ioManagerCapabilitiesChanged = Event.ioManagerCapabilitiesChanged
#else
ioManagerCapabilitiesChanged = return ()
#endif
-- | Block the current thread until data is available to read on the
-- given file descriptor (GHC only).
--
......
......@@ -13,15 +13,9 @@ module GHC.Event
EventManager
-- * Creation
, new
, getSystemEventManager
-- * Running
, loop
-- ** Stepwise running
, step
, shutdown
, new
, getSystemTimerManager
-- * Registering interest in I/O events
, Event
......@@ -44,5 +38,7 @@ module GHC.Event
) where
import GHC.Event.Manager
import GHC.Event.Thread (getSystemEventManager)
import GHC.Event.TimerManager (TimeoutCallback, TimeoutKey, registerTimeout,
updateTimeout, unregisterTimeout)
import GHC.Event.Thread (getSystemEventManager, getSystemTimerManager)
......@@ -47,8 +47,8 @@ import System.Posix.Internals (c_close, c_pipe, c_read, c_write,
import System.Posix.Types (Fd)
#if defined(HAVE_EVENTFD)
import Data.Word (Word64)
import Foreign.C.Error (throwErrnoIfMinus1)
import Foreign.C.Types (CULLong(..))
#else
import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno)
#endif
......@@ -79,8 +79,8 @@ wakeupReadFd = controlEventFd
-- | Create the structure (usually a pipe) used for waking up the IO
-- manager thread from another thread.
newControl :: IO Control
newControl = allocaArray 2 $ \fds -> do
newControl :: Bool -> IO Control
newControl shouldRegister = allocaArray 2 $ \fds -> do
let createPipe = do
throwErrnoIfMinus1_ "pipe" $ c_pipe fds
rd <- peekElemOff fds 0
......@@ -92,15 +92,15 @@ newControl = allocaArray 2 $ \fds -> do
setCloseOnExec wr
return (rd, wr)
(ctrl_rd, ctrl_wr) <- createPipe
c_setIOManagerControlFd ctrl_wr
when shouldRegister $ c_setIOManagerControlFd ctrl_wr
#if defined(HAVE_EVENTFD)
ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0
setNonBlockingFD ev True
setCloseOnExec ev
c_setIOManagerWakeupFd ev
when shouldRegister $ c_setIOManagerWakeupFd ev
#else
(wake_rd, wake_wr) <- createPipe
c_setIOManagerWakeupFd wake_wr
when shouldRegister $ c_setIOManagerWakeupFd wake_wr
#endif
return W { controlReadFd = fromIntegral ctrl_rd
, controlWriteFd = fromIntegral ctrl_wr
......@@ -167,10 +167,9 @@ readControlMessage ctrl fd
sendWakeup :: Control -> IO ()
#if defined(HAVE_EVENTFD)
sendWakeup c = alloca $ \p -> do
poke p (1 :: Word64)
sendWakeup c =
throwErrnoIfMinus1_ "sendWakeup" $
c_write (fromIntegral (controlEventFd c)) (castPtr p) 8
c_eventfd_write (fromIntegral (controlEventFd c)) 1
#else
sendWakeup c = do
n <- sendMessage (wakeupWriteFd c) CMsgWakeup
......@@ -197,6 +196,9 @@ sendMessage fd msg = alloca $ \p -> do
#if defined(HAVE_EVENTFD)
foreign import ccall unsafe "sys/eventfd.h eventfd"
c_eventfd :: CInt -> CInt -> IO CInt
foreign import ccall unsafe "sys/eventfd.h eventfd_write"
c_eventfd_write :: CInt -> CULLong -> IO CInt
#endif
-- Used to tell the RTS how it can send messages to the I/O manager.
......@@ -205,4 +207,3 @@ foreign import ccall "setIOManagerControlFd"
foreign import ccall "setIOManagerWakeupFd"
c_setIOManagerWakeupFd :: CInt -> IO ()
......@@ -40,11 +40,13 @@ available = False
#include <sys/epoll.h>
import Control.Monad (when)
import Control.Monad (unless, when)
import Data.Bits (Bits, (.|.), (.&.))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Word (Word32)
import Foreign.C.Error (throwErrnoIfMinus1, throwErrnoIfMinus1_)
import Foreign.C.Error (eNOENT, getErrno, throwErrno,
throwErrnoIfMinus1, throwErrnoIfMinus1_)
import Foreign.C.Types (CInt(..))
import Foreign.Marshal.Utils (with)
import Foreign.Ptr (Ptr)
......@@ -75,7 +77,7 @@ new :: IO E.Backend
new = do
epfd <- epollCreate
evts <- A.new 64
let !be = E.backend poll modifyFd delete (EPoll epfd evts)
let !be = E.backend poll modifyFd modifyFdOnce delete (EPoll epfd evts)
return be
delete :: EPoll -> IO ()
......@@ -92,25 +94,40 @@ modifyFd ep fd oevt nevt = with (Event (fromEvent nevt) fd) $
| nevt == mempty = controlOpDelete
| otherwise = controlOpModify
modifyFdOnce :: EPoll -> Fd -> E.Event -> IO ()
modifyFdOnce ep fd evt =
do let !ev = fromEvent evt .|. epollOneShot
res <- with (Event ev fd) $
epollControl_ (epollFd ep) controlOpModify fd
unless (res == 0) $ do
err <- getErrno
if err == eNOENT then
with (Event ev fd) $ epollControl (epollFd ep) controlOpAdd fd
else
throwErrno "modifyFdOnce"
-- | Select a set of file descriptors which are ready for I/O
-- operations and call @f@ for all ready file descriptors, passing the
-- events that are ready.
poll :: EPoll -- ^ state
-> Timeout -- ^ timeout in milliseconds
-> Maybe Timeout -- ^ timeout in milliseconds
-> (Fd -> E.Event -> IO ()) -- ^ I/O callback
-> IO ()
poll ep timeout f = do
-> IO Int
poll ep mtimeout f = do
let events = epollEvents ep
fd = epollFd ep
-- Will return zero if the system call was interupted, in which case
-- we just return (and try again later.)
n <- A.unsafeLoad events $ \es cap ->
epollWait (epollFd ep) es cap $ fromTimeout timeout
n <- A.unsafeLoad events $ \es cap -> case mtimeout of
Just timeout -> epollWait fd es cap $ fromTimeout timeout
Nothing -> epollWaitNonBlock fd es cap
when (n > 0) $ do
A.forM_ events $ \e -> f (eventFd e) (toEvent (eventTypes e))
cap <- A.capacity events
when (cap == n) $ A.ensureCapacity events (2 * cap)
return n
newtype EPollFd = EPollFd {
fromEPollFd :: CInt
......@@ -152,6 +169,7 @@ newtype EventType = EventType {
, epollOut = EPOLLOUT
, epollErr = EPOLLERR
, epollHup = EPOLLHUP
, epollOneShot = EPOLLONESHOT
}
-- | Create a new epoll context, returning a file descriptor associated with the context.
......@@ -171,8 +189,12 @@ epollCreate = do
return epollFd'
epollControl :: EPollFd -> ControlOp -> Fd -> Ptr Event -> IO ()
epollControl (EPollFd epfd) (ControlOp op) (Fd fd) event =
throwErrnoIfMinus1_ "epollControl" $ c_epoll_ctl epfd op fd event
epollControl epfd op fd event =
throwErrnoIfMinus1_ "epollControl" $ epollControl_ epfd op fd event
epollControl_ :: EPollFd -> ControlOp -> Fd -> Ptr Event -> IO CInt
epollControl_ (EPollFd epfd) (ControlOp op) (Fd fd) event =
c_epoll_ctl epfd op fd event
epollWait :: EPollFd -> Ptr Event -> Int -> Int -> IO Int
epollWait (EPollFd epfd) events numEvents timeout =
......@@ -180,6 +202,12 @@ epollWait (EPollFd epfd) events numEvents timeout =
E.throwErrnoIfMinus1NoRetry "epollWait" $
c_epoll_wait epfd events (fromIntegral numEvents) (fromIntegral timeout)
epollWaitNonBlock :: EPollFd -> Ptr Event -> Int -> IO Int
epollWaitNonBlock (EPollFd epfd) events numEvents =
fmap fromIntegral .
E.throwErrnoIfMinus1NoRetry "epollWaitNonBlock" $
c_epoll_wait_unsafe epfd events (fromIntegral numEvents) 0
fromEvent :: E.Event -> EventType
fromEvent e = remap E.evtRead epollIn .|.
remap E.evtWrite epollOut
......@@ -207,5 +235,7 @@ foreign import ccall unsafe "sys/epoll.h epoll_ctl"
foreign import ccall safe "sys/epoll.h epoll_wait"
c_epoll_wait :: CInt -> Ptr Event -> CInt -> CInt -> IO CInt
foreign import ccall unsafe "sys/epoll.h epoll_wait"
c_epoll_wait_unsafe :: CInt -> Ptr Event -> CInt -> CInt -> IO CInt
#endif /* defined(HAVE_EPOLL) */
......@@ -9,6 +9,7 @@ module GHC.Event.Internal
, delete
, poll
, modifyFd
, modifyFdOnce
-- * Event type
, Event
, evtRead
......@@ -23,6 +24,7 @@ module GHC.Event.Internal
import Data.Bits ((.|.), (.&.))
import Data.List (foldl', intercalate)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Foreign.C.Error (eINTR, getErrno, throwErrno)
import System.Posix.Types (Fd)
......@@ -90,9 +92,9 @@ data Backend = forall a. Backend {
-- | Poll backend for new events. The provided callback is called
-- once per file descriptor with new events.
, _bePoll :: a -- backend state
-> Timeout -- timeout in milliseconds
-> Maybe Timeout -- timeout in milliseconds ('Nothing' for non-blocking poll)
-> (Fd -> Event -> IO ()) -- I/O callback
-> IO ()
-> IO Int
-- | Register, modify, or unregister interest in the given events
-- on the given file descriptor.
......@@ -102,27 +104,38 @@ data Backend = forall a. Backend {
-> Event -- new events to watch for ('mempty' to delete)
-> IO ()
, _beModifyFdOnce :: a
-> Fd -- file descriptor
-> Event -- new events to watch
-> IO ()
, _beDelete :: a -> IO ()
}
backend :: (a -> Timeout -> (Fd -> Event -> IO ()) -> IO ())
backend :: (a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int)
-> (a -> Fd -> Event -> Event -> IO ())
-> (a -> Fd -> Event -> IO ())
-> (a -> IO ())
-> a
-> Backend
backend bPoll bModifyFd bDelete state = Backend state bPoll bModifyFd bDelete
backend bPoll bModifyFd bModifyFdOnce bDelete state =
Backend state bPoll bModifyFd bModifyFdOnce bDelete
{-# INLINE backend #-}
poll :: Backend -> Timeout -> (Fd -> Event -> IO ()) -> IO ()
poll (Backend bState bPoll _ _) = bPoll bState
poll :: Backend -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
poll (Backend bState bPoll _ _ _) = bPoll bState
{-# INLINE poll #-}
modifyFd :: Backend -> Fd -> Event -> Event -> IO ()
modifyFd (Backend bState _ bModifyFd _) = bModifyFd bState
modifyFd (Backend bState _ bModifyFd _ _) = bModifyFd bState
{-# INLINE modifyFd #-}
modifyFdOnce :: Backend -> Fd -> Event -> IO ()
modifyFdOnce (Backend bState _ _ bModifyFdOnce _) = bModifyFdOnce bState
{-# INLINE modifyFdOnce #-}
delete :: Backend -> IO ()
delete (Backend bState _ _ bDelete) = bDelete bState
delete (Backend bState _ _ _ bDelete) = bDelete bState
{-# INLINE delete #-}
-- | Throw an 'IOError' corresponding to the current value of
......
......@@ -28,9 +28,10 @@ available = False
{-# INLINE available #-}
#else
import Control.Concurrent.MVar (MVar, newMVar, swapMVar, withMVar)
import Control.Monad (when, unless)
import Control.Monad (when, void)
import Data.Bits (Bits(..))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Word (Word16, Word32)
import Foreign.C.Error (throwErrnoIfMinus1)
import Foreign.C.Types
......@@ -48,10 +49,7 @@ import System.Posix.Internals (c_close)
import System.Posix.Types (Fd(..))
import qualified GHC.Event.Array as A
#if defined(HAVE_KEVENT64)
import Data.Int (Int64)
import Data.Word (Word64)
#elif defined(netbsd_HOST_OS)
#if defined(netbsd_HOST_OS)
import Data.Int (Int64)
#endif
......@@ -73,103 +71,66 @@ available = True
------------------------------------------------------------------------
-- Exported interface
data EventQueue = EventQueue {
eqFd :: {-# UNPACK #-} !QueueFd
, eqChanges :: {-# UNPACK #-} !(MVar (A.Array Event))
, eqEvents :: {-# UNPACK #-} !(A.Array Event)
data KQueue = KQueue {
kqueueFd :: {-# UNPACK #-} !KQueueFd
, kqueueEvents :: {-# UNPACK #-} !(A.Array Event)
}
new :: IO E.Backend
new = do
qfd <- kqueue
changesArr <- A.empty
changes <- newMVar changesArr
kqfd <- kqueue
events <- A.new 64
let !be = E.backend poll modifyFd delete (EventQueue qfd changes events)
let !be = E.backend poll modifyFd modifyFdOnce delete (KQueue kqfd events)
return be
delete :: EventQueue -> IO ()
delete q = do
_ <- c_close . fromQueueFd . eqFd $ q
delete :: KQueue -> IO ()
delete kq = do
_ <- c_close . fromKQueueFd . kqueueFd $ kq
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
modifyFd :: KQueue -> Fd -> E.Event -> E.Event -> IO ()
modifyFd kq fd oevt nevt
| nevt == mempty = do
let !ev = event fd (toFilter oevt) flagDelete noteEOF
kqueueControl (kqueueFd kq) ev
| otherwise = do
let !ev = event fd (toFilter nevt) flagAdd noteEOF
kqueueControl (kqueueFd kq) ev
toFilter :: E.Event -> Filter
toFilter evt
| evt `E.eventIs` E.evtRead = filterRead
| otherwise = filterWrite
modifyFdOnce :: KQueue -> Fd -> E.Event -> IO ()
modifyFdOnce kq fd evt = do
let !ev = event fd (toFilter evt) (flagAdd .|. flagOneshot) noteEOF
kqueueControl (kqueueFd kq) ev
poll :: KQueue
-> Maybe 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))
-> 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
------------------------------------------------------------------------
-- FFI binding
newtype QueueFd = QueueFd {
fromQueueFd :: CInt
newtype KQueueFd = KQueueFd {
fromKQueueFd :: CInt
} deriving (Eq, Show)
#if defined(HAVE_KEVENT64)
data Event = KEvent64 {
ident :: {-# UNPACK #-} !Word64
, filter :: {-# UNPACK #-} !Filter
, flags :: {-# UNPACK #-} !Flag
, fflags :: {-# UNPACK #-} !FFlag
, data_ :: {-# UNPACK #-} !Int64
, udata :: {-# UNPACK #-} !Word64
, ext0 :: {-# UNPACK #-} !Word64
, ext1 :: {-# UNPACK #-} !Word64
} deriving Show
event :: Fd -> Filter -> Flag -> FFlag -> Event
event fd filt flag fflag = KEvent64 (fromIntegral fd) filt flag fflag 0 0 0 0
instance Storable Event where
sizeOf _ = #size struct kevent64_s
alignment _ = alignment (undefined :: CInt)
peek ptr = do
ident' <- #{peek struct kevent64_s, ident} ptr
filter' <- #{peek struct kevent64_s, filter} ptr
flags' <- #{peek struct kevent64_s, flags} ptr
fflags' <- #{peek struct kevent64_s, fflags} ptr
data' <- #{peek struct kevent64_s, data} ptr
udata' <- #{peek struct kevent64_s, udata} ptr
ext0' <- #{peek struct kevent64_s, ext[0]} ptr
ext1' <- #{peek struct kevent64_s, ext[1]} ptr
let !ev = KEvent64 ident' (Filter filter') (Flag flags') fflags' data'
udata' ext0' ext1'
return ev
poke ptr ev = do
#{poke struct kevent64_s, ident} ptr (ident ev)
#{poke struct kevent64_s, filter} ptr (filter ev)
#{poke struct kevent64_s, flags} ptr (flags ev)
#{poke struct kevent64_s, fflags} ptr (fflags ev)
#{poke struct kevent64_s, data} ptr (data_ ev)
#{poke struct kevent64_s, udata} ptr (udata ev)
#{poke struct kevent64_s, ext[0]} ptr (ext0 ev)
#{poke struct kevent64_s, ext[1]} ptr (ext1 ev)
#else
data Event = KEvent {
ident :: {-# UNPACK #-} !CUIntPtr
, filter :: {-# UNPACK #-} !Filter
......@@ -208,7 +169,6 @@ instance Storable Event where
#{poke struct kevent, fflags} ptr (fflags ev)
#{poke struct kevent, data} ptr (data_ ev)
#{poke struct kevent, udata} ptr (udata ev)
#endif
newtype FFlag = FFlag Word32
deriving (Eq, Show, Storable)
......@@ -222,11 +182,12 @@ newtype Flag = Flag Word32
#else
newtype Flag = Flag Word16
#endif
deriving (Eq, Show, Storable)
deriving (Bits, Eq, Num, Show, Storable)
#{enum Flag, Flag
, flagAdd = EV_ADD
, flagDelete = EV_DELETE
, flagOneshot = EV_ONESHOT
}
#if SIZEOF_KEV_FILTER == 4 /*kevent.filter: uint32_t or uint16_t. */
......@@ -260,27 +221,39 @@ instance Storable TimeSpec where
#{poke struct timespec, tv_sec} ptr (tv_sec ts)
#{poke struct timespec, tv_nsec} ptr (tv_nsec ts)
kqueue :: IO QueueFd
kqueue = QueueFd `fmap` throwErrnoIfMinus1 "kqueue" c_kqueue
kqueue :: IO KQueueFd
kqueue = KQueueFd `fmap` throwErrnoIfMinus1 "kqueue" c_kqueue
kqueueControl :: KQueueFd -> Event -> IO ()
kqueueControl kfd ev = void $
withTimeSpec (TimeSpec 0 0) $ \tp ->
withEvent ev $ \evp -> kevent False kfd evp 1 nullPtr 0 tp
kqueueWait :: KQueueFd -> Ptr Event -> Int -> TimeSpec -> IO Int
kqueueWait fd es cap tm =
withTimeSpec tm $ kevent True fd nullPtr 0 es cap
kqueueWaitNonBlock :: KQueueFd -> Ptr Event -> Int -> IO Int
kqueueWaitNonBlock fd es cap =
withTimeSpec (TimeSpec 0 0) $ kevent False fd nullPtr 0 es cap
-- TODO: We cannot retry on EINTR as the timeout would be wrong.
-- Perhaps we should just return without calling any callbacks.
kevent :: QueueFd -> Ptr Event -> Int -> Ptr Event -> Int -> Ptr TimeSpec
kevent :: Bool -> KQueueFd -> Ptr Event -> Int -> Ptr Event -> Int -> Ptr TimeSpec
-> IO Int
kevent k chs chlen evs evlen ts
kevent safe k chs chlen evs evlen ts
= fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $
#if defined(HAVE_KEVENT64)
c_kevent64 k chs (fromIntegral chlen) evs (fromIntegral evlen) 0 ts
#else
c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
#endif
if safe
then c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
else c_kevent_unsafe k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
withEvent :: Event -> (Ptr Event -> IO a) -> IO a
withEvent ev f = alloca $ \ptr -> poke ptr ev >> f ptr
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
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)
......@@ -294,24 +267,23 @@ fromTimeout (Timeout s) = TimeSpec (toEnum sec) (toEnum nanosec)
toEvent :: Filter -> E.Event
toEvent (Filter f)
| f == (#const EVFILT_READ) = E.evtRead
| f == (#const EVFILT_WRITE) = E.evtWrite
| otherwise = error $ "toEvent: unknown filter " ++ show f
| f == (#const EVFILT_READ) = E.evtRead
| f == (#const EVFILT_WRITE) = E.evtWrite
| otherwise = error $ "toEvent: unknown filter " ++ show f
foreign import ccall unsafe "kqueue"
c_kqueue :: IO CInt
#if defined(HAVE_KEVENT64)
foreign import ccall safe "kevent64"
c_kevent64 :: QueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt -> CUInt
-> Ptr TimeSpec -> IO CInt
#elif defined(HAVE_KEVENT)
#if defined(HAVE_KEVENT)
foreign import capi safe "sys/event.h kevent"
c_kevent :: QueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt
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
#else
#error no kevent system call available!?
#endif
#endif /* defined(HAVE_KQUEUE) */
This diff is collapsed.
......@@ -55,7 +55,7 @@ data Poll = Poll {
}
new :: IO E.Backend
new = E.backend poll modifyFd (\_ -> return ()) `liftM`
new = E.backend poll modifyFd modifyFdOnce (\_ -> return ()) `liftM`
liftM2 Poll (newMVar =<< A.empty) A.empty
modifyFd :: Poll -> Fd -> E.Event -> E.Event -> IO ()
......@@ -63,6 +63,9 @@ modifyFd p fd oevt nevt =
withMVar (pollChanges p) $ \ary ->
A.snoc ary $ PollFd fd (fromEvent nevt) (fromEvent oevt)
modifyFdOnce :: Poll -> Fd -> E.Event -> IO ()
modifyFdOnce = error "modifyFdOnce not supported in Poll backend"
reworkFd :: Poll -> PollFd -> IO ()
reworkFd p (PollFd fd npevt opevt) = do
let ary = pollFd p
......@@ -77,15 +80,20 @@ reworkFd p (PollFd fd npevt opevt) = do
| otherwise -> A.removeAt ary i
poll :: Poll
-> E.Timeout
-> Maybe E.Timeout
-> (Fd -> E.Event -> IO ())
-> IO ()
poll p tout f = do
-> IO Int
poll p mtout f = do
let a = pollFd p
mods <- swapMVar (pollChanges p) =<< A.empty
A.forM_ mods (reworkFd p)
n <- A.useAsPtr a $ \ptr len -> E.throwErrnoIfMinus1NoRetry "c_poll" $
c_poll ptr (fromIntegral len) (fromIntegral (fromTimeout tout))
n <- A.useAsPtr a $ \ptr len ->
E.throwErrnoIfMinus1NoRetry "c_poll" $
case mtout of
Just tout ->
c_poll ptr (fromIntegral len) (fromIntegral (fromTimeout tout))
Nothing ->
c_poll_unsafe ptr (fromIntegral len) 0
unless (n == 0) $ do
A.loop a 0 $ \i e -> do
let r = pfdRevents e
......@@ -94,6 +102,7 @@ poll p tout f = do
let i' = i + 1
return (i', i' == n)
else return (i, True)
return (fromIntegral n)