Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Switch the public event type over to a monoidal set.

The EPoll back end is migrated, but not yet KQueue.
  • Loading branch information...
commit a66af36a51cf4daec1b5a81ecb6303418701852b 1 parent bf059b3
@bos bos authored
View
10 benchmarks/Simple.hs
@@ -21,7 +21,7 @@ import Foreign.Ptr (Ptr)
import Foreign.C.Types (CChar)
import System.Console.GetOpt (ArgDescr(ReqArg), OptDescr(..))
import System.Environment (getArgs)
-import System.Event (Event(..), loop, new, registerFd)
+import System.Event (Event(..), evtRead, evtWrite, loop, new, registerFd)
import System.Posix.IO (createPipe)
import System.Posix.Resource (ResourceLimit(..), ResourceLimits(..),
Resource(..), setResourceLimit)
@@ -53,7 +53,7 @@ defaultOptions = [
"number of pipes to use"
]
-readCallback :: MVar () -> IORef Int -> Fd -> [Event] -> IO ()
+readCallback :: MVar () -> IORef Int -> Fd -> Event -> IO ()
readCallback done ref fd _ = do
a <- atomicModifyIORef ref (\a -> let !b = a+1 in (b,b))
print ("read",fd,a)
@@ -64,7 +64,7 @@ readCallback done ref fd _ = do
else do
readByte fd
-writeCallback :: IORef Int -> Fd -> [Event] -> IO ()
+writeCallback :: IORef Int -> Fd -> Event -> IO ()
writeCallback ref fd _ = do
a <- atomicModifyIORef ref (\a -> let !b = a+1 in (b,b))
print ("write",fd,a)
@@ -91,8 +91,8 @@ main = do
wref <- newIORef 0
done <- newEmptyMVar
forM_ pipePairs $ \(r,w) -> do
- registerFd mgr (readCallback done rref r) r [Read]
- registerFd mgr (writeCallback wref w) w [Write]
+ registerFd mgr (readCallback done rref r) r evtRead
+ registerFd mgr (writeCallback wref w) w evtWrite
let pipeArray :: UArray Int Int32
pipeArray = listArray (0, numPipes) . map fromIntegral $ pipes
View
14 src/System/Event.hs
@@ -10,7 +10,9 @@ module System.Event
new,
-- * Registering interest in I/O events
- Event(..),
+ Event,
+ evtRead,
+ evtWrite,
IOCallback,
registerFd,
@@ -36,7 +38,7 @@ import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime,
import Data.Unique
import System.Posix.Types (Fd)
-import System.Event.Internal (Backend, Event(..), Timeout(..), wmWakeup)
+import System.Event.Internal (Backend, Event, evtRead, evtWrite, Timeout(..), wmWakeup)
import qualified System.Event.Internal as I
import qualified System.Event.TimeoutTable as TT
@@ -52,7 +54,7 @@ import qualified System.Event.EPoll as Backend
-- Types
-- | Vector of I/O callbacks, indexed by file descriptor.
-type IOCallbacks = IntMap ([Event] -> IO ())
+type IOCallbacks = IntMap (Event -> IO ())
-- FIXME: choose a quicker time representation than UTCTime? We'll be calling
-- "getCurrentTime" a lot.
@@ -122,12 +124,12 @@ loop mgr@(EventManager be _ tt) = go =<< getCurrentTime
-- Registering interest in I/O events
-- | Callback invoked on I/O events.
-type IOCallback = [Event] -> IO ()
+type IOCallback = Event -> IO ()
-- | @registerFd mgr cb fd evs@ registers interest in the events @evs@
-- on the file descriptor @fd@. @cb@ is called for each event that
-- occurs.
-registerFd :: EventManager -> IOCallback -> Fd -> [Event] -> IO ()
+registerFd :: EventManager -> IOCallback -> Fd -> Event -> IO ()
registerFd (EventManager be cbs _) cb fd evs = do
atomicModifyIORef cbs $ \c -> (IM.insert (fromIntegral fd) cb c, ())
I.set be (fromIntegral fd) evs
@@ -163,7 +165,7 @@ updateTimeout (EventManager be _ tt) key ms = do
-- Utilities
-- | Call the callback corresponding to the given file descriptor.
-onFdEvent :: EventManager -> Fd -> [Event] -> IO ()
+onFdEvent :: EventManager -> Fd -> Event -> IO ()
onFdEvent (EventManager _ cbs' _) fd evs = do
cbs <- readIORef cbs'
case IM.lookup (fromIntegral fd) cbs of
View
35 src/System/Event/EPoll.hsc
@@ -5,7 +5,8 @@ module System.Event.EPoll where
#include <sys/epoll.h>
import Control.Monad (liftM3, when)
-import Data.Bits ((.|.))
+import Data.Bits ((.|.), (.&.))
+import Data.Monoid (Monoid(..))
import Data.Word (Word32)
import Foreign.C.Error (throwErrnoIfMinus1, throwErrnoIfMinus1_)
import Foreign.C.Types (CInt)
@@ -33,19 +34,16 @@ instance E.Backend EPoll where
new :: IO EPoll
new = do
ep <- liftM3 EPoll epollCreate (A.new 64) E.createWakeup
- set ep (E.wakeupReadFd . epollWakeup $ ep) [E.Read]
+ set ep (E.wakeupReadFd . epollWakeup $ ep) E.evtRead
return ep
-set :: EPoll -> Fd -> [E.Event] -> IO ()
-set ep fd events =
- with e $ epollControl (epollFd ep) controlOpAdd fd
- where
- e = Event ets fd
- ets = combineEventTypes (map fromEvent events)
+set :: EPoll -> Fd -> E.Event -> IO ()
+set ep fd events = with e $ epollControl (epollFd ep) controlOpAdd fd
+ where e = Event (fromEvent events) fd
poll :: EPoll -- ^ state
-> Timeout -- ^ timeout in milliseconds
- -> (Fd -> [E.Event] -> IO ()) -- ^ I/O callback
+ -> (Fd -> E.Event -> IO ()) -- ^ I/O callback
-> IO E.Result
poll ep timeout f = do
let epfd = epollFd ep
@@ -60,7 +58,7 @@ poll ep timeout f = do
cap <- A.capacity events
when (n == cap) $ A.ensureCapacity events (2 * cap)
- A.mapM_ events $ \e -> f (eventFd e) []
+ A.mapM_ events $ \e -> f (eventFd e) (toEvent (eventTypes e))
return E.Activity
@@ -99,9 +97,6 @@ newtype EventType = EventType {
unEventType :: Word32
} deriving (Show)
-combineEventTypes :: [EventType] -> EventType
-combineEventTypes = EventType . foldr ((.|.) . unEventType) 0
-
epollCreate :: IO EPollFd
epollCreate =
fmap EPollFd .
@@ -119,8 +114,18 @@ epollWait (EPollFd epfd) events numEvents timeout =
c_epoll_wait epfd events (fromIntegral numEvents) (fromIntegral timeout)
fromEvent :: E.Event -> EventType
-fromEvent E.Read = EventType #const EPOLLIN
-fromEvent E.Write = EventType #const EPOLLOUT
+fromEvent e = EventType (remap E.evtRead (#const EPOLLIN) .|.
+ remap E.evtWrite (#const EPOLLOUT))
+ where remap evt to
+ | e `E.eventIs` evt = to
+ | otherwise = 0
+
+toEvent :: EventType -> E.Event
+toEvent (EventType e) = remap (#const EPOLLIN) E.evtRead `mappend`
+ remap (#const EPOLLOUT) E.evtWrite
+ where remap evt to
+ | e .&. evt /= 0 = to
+ | otherwise = mempty
fromTimeout :: Timeout -> Int
fromTimeout Forever = -1
View
41 src/System/Event/Internal.hsc
@@ -2,7 +2,10 @@ module System.Event.Internal
(
-- * Core types
Backend(..)
- , Event(..)
+ , Event
+ , evtRead
+ , evtWrite
+ , eventIs
, Result(..)
, Timeout(..)
-- * Managing the IO manager
@@ -20,6 +23,8 @@ module System.Event.Internal
) where
import Control.Monad (liftM)
+import Data.Bits ((.|.), (.&.))
+import Data.Monoid (Monoid(..))
import Foreign.C.Error (throwErrnoIfMinus1_)
import Foreign.C.Types (CChar, CInt)
import Foreign.Marshal (alloca)
@@ -30,8 +35,34 @@ import System.Posix.Internals (c_close, c_pipe, c_read, c_write,
import System.Posix.Types (Fd)
-- | An I/O event.
-data Event = Read -- ^ The file descriptor is ready to be read
- | Write -- ^ The file descriptor is ready to be written to
+newtype Event = Event Int
+ deriving (Eq)
+
+evtNothing :: Event
+evtNothing = Event 0
+{-# INLINE evtNothing #-}
+
+evtRead :: Event
+evtRead = Event 1
+
+evtWrite :: Event
+evtWrite = Event 2
+
+eventIs :: Event -> Event -> Bool
+eventIs (Event a) (Event b) = a .&. b /= 0
+
+instance Show Event where
+ show e | e `eventIs` evtRead = "evtRead"
+ | e `eventIs` evtWrite = "evtWrite"
+ | otherwise = error "show: illegal value"
+
+instance Monoid Event where
+ mempty = evtNothing
+ mappend = evtCombine
+
+evtCombine :: Event -> Event -> Event
+evtCombine (Event a) (Event b) = Event (a .|. b)
+{-# INLINE evtCombine #-}
-- | A type alias for timeouts
data Timeout = Timeout CInt
@@ -63,14 +94,14 @@ class Backend a where
-- once per file descriptor with new events.
poll :: a -- ^ backend state
-> Timeout -- ^ timeout in milliseconds
- -> (Fd -> [Event] -> IO ()) -- ^ I/O callback
+ -> (Fd -> Event -> IO ()) -- ^ I/O callback
-> IO Result
-- | Register interest in the given events on the given file
-- descriptor.
set :: a
-> Fd -- ^ file descriptor
- -> [Event] -- ^ events to watch for
+ -> Event -- ^ events to watch for
-> IO ()
-- | This should cause the underlying polling mechanism to
Please sign in to comment.
Something went wrong with that request. Please try again.