System/Event/EPoll.hsc

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