GHC/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 GHC.Event.EPoll
  18     (
  19       new
  20     , available
  21     ) where
  22
  23 import qualified GHC.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 import System.Posix.Internals (setCloseOnExec)
  55 import System.Posix.Types (Fd(..))
  56
  57 import qualified GHC.Event.Array    as A
  58 import           GHC.Event.Internal (Timeout(..))
  59
  60 available :: Bool
  61 available = True
  62 {-# INLINE available #-}
  63
  64 data EPoll = EPoll {
  65       epollFd     :: {-# UNPACK #-} !EPollFd
  66     , epollEvents :: {-# UNPACK #-} !(A.Array Event)
  67     }
  68
  69 -- | Create a new epoll backend.
  70 new :: IO E.Backend
  71 new = do
  72   epfd <- epollCreate
  73   evts <- A.new 64
  74   let !be = E.backend poll modifyFd delete (EPoll epfd evts)
  75   return be
  76
  77 delete :: EPoll -> IO ()
  78 delete be = do
  79   _ <- c_close . fromEPollFd . epollFd $ be
  80   return ()
  81
  82 -- | Change the set of events we are interested in for a given file
  83 -- descriptor.
  84 modifyFd :: EPoll -> Fd -> E.Event -> E.Event -> IO ()
  85 modifyFd ep fd oevt nevt = with (Event (fromEvent nevt) fd) $
  86                              epollControl (epollFd ep) op fd
  87   where op | oevt == mempty = controlOpAdd
  88            | nevt == mempty = controlOpDelete
  89            | otherwise      = controlOpModify
  90
  91 -- | Select a set of file descriptors which are ready for I/O
  92 -- operations and call @f@ for all ready file descriptors, passing the
  93 -- events that are ready.
  94 poll :: EPoll                     -- ^ state
  95      -> Timeout                   -- ^ timeout in milliseconds
  96      -> (Fd -> E.Event -> IO ())  -- ^ I/O callback
  97      -> IO ()
  98 poll ep timeout f = do
  99   let events = epollEvents ep
 100
 101   -- Will return zero if the system call was interupted, in which case
 102   -- we just return (and try again later.)
 103   n <- A.unsafeLoad events $ \es cap ->
 104        epollWait (epollFd ep) es cap $ fromTimeout timeout
 105
 106   when (n > 0) $ do
 107     A.forM_ events $ \e -> f (eventFd e) (toEvent (eventTypes e))
 108     cap <- A.capacity events
 109     when (cap == n) $ A.ensureCapacity events (2 * cap)
 110
 111 newtype EPollFd = EPollFd {
 112       fromEPollFd :: CInt
 113     } deriving (Eq, Show)
 114
 115 data Event = Event {
 116       eventTypes :: EventType
 117     , eventFd    :: Fd
 118     } deriving (Show)
 119
 120 instance Storable Event where
 121     sizeOf    _ = #size struct epoll_event
 122     alignment _ = alignment (undefined :: CInt)
 123
 124     peek ptr = do
 125         ets <- #{peek struct epoll_event, events} ptr
 126         ed  <- #{peek struct epoll_event, data.fd}   ptr
 127         let !ev = Event (EventType ets) ed
 128         return ev
 129
 130     poke ptr e = do
 131         #{poke struct epoll_event, events} ptr (unEventType $ eventTypes e)
 132         #{poke struct epoll_event, data.fd}   ptr (eventFd e)
 133
 134 newtype ControlOp = ControlOp CInt
 135
 136 #{enum ControlOp, ControlOp
 137  , controlOpAdd    = EPOLL_CTL_ADD
 138  , controlOpModify = EPOLL_CTL_MOD
 139  , controlOpDelete = EPOLL_CTL_DEL
 140  }
 141
 142 newtype EventType = EventType {
 143       unEventType :: Word32
 144     } deriving (Show, Eq, Num, Bits)
 145
 146 #{enum EventType, EventType
 147  , epollIn  = EPOLLIN
 148  , epollOut = EPOLLOUT
 149  , epollErr = EPOLLERR
 150  , epollHup = EPOLLHUP
 151  }
 152
 153 -- | Create a new epoll context, returning a file descriptor associated with the context.
 154 -- The fd may be used for subsequent calls to this epoll context.
 155 --
 156 -- The size parameter to epoll_create is a hint about the expected number of handles.
 157 --
 158 -- The file descriptor returned from epoll_create() should be destroyed via
 159 -- a call to close() after polling is finished
 160 --
 161 epollCreate :: IO EPollFd
 162 epollCreate = do
 163   fd <- throwErrnoIfMinus1 "epollCreate" $
 164         c_epoll_create 256 -- argument is ignored
 165   setCloseOnExec fd
 166   let !epollFd' = EPollFd fd
 167   return epollFd'
 168
 169 epollControl :: EPollFd -> ControlOp -> Fd -> Ptr Event -> IO ()
 170 epollControl (EPollFd epfd) (ControlOp op) (Fd fd) event =
 171     throwErrnoIfMinus1_ "epollControl" $ c_epoll_ctl epfd op fd event
 172
 173 epollWait :: EPollFd -> Ptr Event -> Int -> Int -> IO Int
 174 epollWait (EPollFd epfd) events numEvents timeout =
 175     fmap fromIntegral .
 176     E.throwErrnoIfMinus1NoRetry "epollWait" $
 177     c_epoll_wait epfd events (fromIntegral numEvents) (fromIntegral timeout)
 178
 179 fromEvent :: E.Event -> EventType
 180 fromEvent e = remap E.evtRead  epollIn .|.
 181               remap E.evtWrite epollOut
 182   where remap evt to
 183             | e `E.eventIs` evt = to
 184             | otherwise         = 0
 185
 186 toEvent :: EventType -> E.Event
 187 toEvent e = remap (epollIn  .|. epollErr .|. epollHup) E.evtRead `mappend`
 188             remap (epollOut .|. epollErr .|. epollHup) E.evtWrite
 189   where remap evt to
 190             | e .&. evt /= 0 = to
 191             | otherwise      = mempty
 192
 193 fromTimeout :: Timeout -> Int
 194 fromTimeout Forever     = -1
 195 fromTimeout (Timeout s) = ceiling $ 1000 * s
 196
 197 foreign import ccall unsafe "sys/epoll.h epoll_create"
 198     c_epoll_create :: CInt -> IO CInt
 199
 200 foreign import ccall unsafe "sys/epoll.h epoll_ctl"
 201     c_epoll_ctl :: CInt -> CInt -> CInt -> Ptr Event -> IO CInt
 202
 203 foreign import ccall safe "sys/epoll.h epoll_wait"
 204     c_epoll_wait :: CInt -> Ptr Event -> CInt -> CInt -> IO CInt
 205
 206 #endif /* defined(HAVE_EPOLL) */