System/Event/EPoll.hsc

   1 {-# LANGUAGE CPP
   2            , ForeignFunctionInterface
   3            , GeneralizedNewtypeDeriving
   4            , NoImplicitPrelude
   5            , BangPatterns
   6   #-}
   7
   8 --
   9 -- | A binding to the epoll I/O event notification facility
  10 --
  11 -- epoll is a variant of poll that can be used either as an edge-triggered or
  12 -- a level-triggered interface and scales well to large numbers of watched file
  13 -- descriptors.
  14 --
  15 -- epoll decouples monitor an fd from the process of registering it.
  16 --
  17 module System.Event.EPoll
  18     (
  19       new
  20     , available
  21     ) where
  22
  23 import qualified System.Event.Internal as E
  24
  25 #include "EventConfig.h"
  26 #if !defined(HAVE_EPOLL)
  27 import GHC.Base
  28
  29 new :: IO E.Backend
  30 new = error "EPoll back end not implemented for this platform"
  31
  32 available :: Bool
  33 available = False
  34 {-# INLINE available #-}
  35 #else
  36
  37 #include <sys/epoll.h>
  38
  39 import Control.Monad (when)
  40 import Data.Bits (Bits, (.|.), (.&.))
  41 import Data.Monoid (Monoid(..))
  42 import Data.Word (Word32)
  43 import Foreign.C.Error (throwErrnoIfMinus1, throwErrnoIfMinus1_)
  44 import Foreign.C.Types (CInt)
  45 import Foreign.Marshal.Utils (with)
  46 import Foreign.Ptr (Ptr)
  47 import Foreign.Storable (Storable(..))
  48 import GHC.Base
  49 import GHC.Err (undefined)
  50 import GHC.Num (Num(..))
  51 import GHC.Real (ceiling, fromIntegral)
  52 import GHC.Show (Show)
  53 import System.Posix.Internals (c_close)
  54 #if !defined(HAVE_EPOLL_CREATE1)
  55 import System.Posix.Internals (setCloseOnExec)
  56 #endif
  57 import System.Posix.Types (Fd(..))
  58
  59 import qualified System.Event.Array    as A
  60 import           System.Event.Internal (Timeout(..))
  61
  62 available :: Bool
  63 available = True
  64 {-# INLINE available #-}
  65
  66 data EPoll = EPoll {
  67       epollFd     :: {-# UNPACK #-} !EPollFd
  68     , epollEvents :: {-# UNPACK #-} !(A.Array Event)
  69     }
  70
  71 -- | Create a new epoll backend.
  72 new :: IO E.Backend
  73 new = do
  74   epfd <- epollCreate
  75   evts <- A.new 64
  76   let !be = E.backend poll modifyFd delete (EPoll epfd evts)
  77   return be
  78
  79 delete :: EPoll -> IO ()
  80 delete be = do
  81   _ <- c_close . fromEPollFd . epollFd $ be
  82   return ()
  83
  84 -- | Change the set of events we are interested in for a given file
  85 -- descriptor.
  86 modifyFd :: EPoll -> Fd -> E.Event -> E.Event -> IO ()
  87 modifyFd ep fd oevt nevt = with (Event (fromEvent nevt) fd) $
  88                              epollControl (epollFd ep) op fd
  89   where op | oevt == mempty = controlOpAdd
  90            | nevt == mempty = controlOpDelete
  91            | otherwise      = controlOpModify
  92
  93 -- | Select a set of file descriptors which are ready for I/O
  94 -- operations and call @f@ for all ready file descriptors, passing the
  95 -- events that are ready.
  96 poll :: EPoll                     -- ^ state
  97      -> Timeout                   -- ^ timeout in milliseconds
  98      -> (Fd -> E.Event -> IO ())  -- ^ I/O callback
  99      -> IO ()
 100 poll ep timeout f = do
 101   let events = epollEvents ep
 102
 103   -- Will return zero if the system call was interupted, in which case
 104   -- we just return (and try again later.)
 105   n <- A.unsafeLoad events $ \es cap ->
 106        epollWait (epollFd ep) es cap $ fromTimeout timeout
 107
 108   when (n > 0) $ do
 109     A.forM_ events $ \e -> f (eventFd e) (toEvent (eventTypes e))
 110     cap <- A.capacity events
 111     when (cap == n) $ A.ensureCapacity events (2 * cap)
 112
 113 newtype EPollFd = EPollFd {
 114       fromEPollFd :: CInt
 115     } deriving (Eq, Show)
 116
 117 data Event = Event {
 118       eventTypes :: EventType
 119     , eventFd    :: Fd
 120     } deriving (Show)
 121
 122 instance Storable Event where
 123     sizeOf    _ = #size struct epoll_event
 124     alignment _ = alignment (undefined :: CInt)
 125
 126     peek ptr = do
 127         ets <- #{peek struct epoll_event, events} ptr
 128         ed  <- #{peek struct epoll_event, data.fd}   ptr
 129         let !ev = Event (EventType ets) ed
 130         return ev
 131
 132     poke ptr e = do
 133         #{poke struct epoll_event, events} ptr (unEventType $ eventTypes e)
 134         #{poke struct epoll_event, data.fd}   ptr (eventFd e)
 135
 136 newtype ControlOp = ControlOp CInt
 137
 138 #{enum ControlOp, ControlOp
 139  , controlOpAdd    = EPOLL_CTL_ADD
 140  , controlOpModify = EPOLL_CTL_MOD
 141  , controlOpDelete = EPOLL_CTL_DEL
 142  }
 143
 144 newtype EventType = EventType {
 145       unEventType :: Word32
 146     } deriving (Show, Eq, Num, Bits)
 147
 148 #{enum EventType, EventType
 149  , epollIn  = EPOLLIN
 150  , epollOut = EPOLLOUT
 151  , epollErr = EPOLLERR
 152  , epollHup = EPOLLHUP
 153  }
 154
 155 -- | Create a new epoll context, returning a file descriptor associated with the context.
 156 -- The fd may be used for subsequent calls to this epoll context.
 157 --
 158 -- The size parameter to epoll_create is a hint about the expected number of handles.
 159 --
 160 -- The file descriptor returned from epoll_create() should be destroyed via
 161 -- a call to close() after polling is finished
 162 --
 163 epollCreate :: IO EPollFd
 164 epollCreate = do
 165   fd <- throwErrnoIfMinus1 "epollCreate" $
 166 #if defined(HAVE_EPOLL_CREATE1)
 167         c_epoll_create1 (#const EPOLL_CLOEXEC)
 168 #else
 169         c_epoll_create 256 -- argument is ignored
 170   setCloseOnExec fd
 171 #endif
 172   let !epollFd' = EPollFd fd
 173   return epollFd'
 174
 175 epollControl :: EPollFd -> ControlOp -> Fd -> Ptr Event -> IO ()
 176 epollControl (EPollFd epfd) (ControlOp op) (Fd fd) event =
 177     throwErrnoIfMinus1_ "epollControl" $ c_epoll_ctl epfd op fd event
 178
 179 epollWait :: EPollFd -> Ptr Event -> Int -> Int -> IO Int
 180 epollWait (EPollFd epfd) events numEvents timeout =
 181     fmap fromIntegral .
 182     E.throwErrnoIfMinus1NoRetry "epollWait" $
 183     c_epoll_wait epfd events (fromIntegral numEvents) (fromIntegral timeout)
 184
 185 fromEvent :: E.Event -> EventType
 186 fromEvent e = remap E.evtRead  epollIn .|.
 187               remap E.evtWrite epollOut
 188   where remap evt to
 189             | e `E.eventIs` evt = to
 190             | otherwise         = 0
 191
 192 toEvent :: EventType -> E.Event
 193 toEvent e = remap (epollIn  .|. epollErr .|. epollHup) E.evtRead `mappend`
 194             remap (epollOut .|. epollErr .|. epollHup) E.evtWrite
 195   where remap evt to
 196             | e .&. evt /= 0 = to
 197             | otherwise      = mempty
 198
 199 fromTimeout :: Timeout -> Int
 200 fromTimeout Forever     = -1
 201 fromTimeout (Timeout s) = ceiling $ 1000 * s
 202
 203 #if defined(HAVE_EPOLL_CREATE1)
 204 foreign import ccall unsafe "sys/epoll.h epoll_create1"
 205     c_epoll_create1 :: CInt -> IO CInt
 206 #else
 207 foreign import ccall unsafe "sys/epoll.h epoll_create"
 208     c_epoll_create :: CInt -> IO CInt
 209 #endif
 210
 211 foreign import ccall unsafe "sys/epoll.h epoll_ctl"
 212     c_epoll_ctl :: CInt -> CInt -> CInt -> Ptr Event -> IO CInt
 213
 214 foreign import ccall safe "sys/epoll.h epoll_wait"
 215     c_epoll_wait :: CInt -> Ptr Event -> CInt -> CInt -> IO CInt
 216
 217 #endif /* defined(HAVE_EPOLL) */