System/Event/Poll.hsc

   1 {-# LANGUAGE CPP
   2            , ForeignFunctionInterface
   3            , GeneralizedNewtypeDeriving
   4            , NoImplicitPrelude
   5            , BangPatterns
   6   #-}
   7
   8 module System.Event.Poll
   9     (
  10       new
  11     , available
  12     ) where
  13
  14 #include "EventConfig.h"
  15
  16 #if !defined(HAVE_POLL_H)
  17 import GHC.Base
  18
  19 new :: IO E.Backend
  20 new = error "Poll back end not implemented for this platform"
  21
  22 available :: Bool
  23 available = False
  24 {-# INLINE available #-}
  25 #else
  26 #include <poll.h>
  27
  28 import Control.Concurrent.MVar (MVar, newMVar, swapMVar)
  29 import Control.Monad ((=<<), liftM, liftM2, unless)
  30 import Data.Bits (Bits, (.|.), (.&.))
  31 import Data.Maybe (Maybe(..))
  32 import Data.Monoid (Monoid(..))
  33 import Foreign.C.Types (CInt, CShort, CULong)
  34 import Foreign.Ptr (Ptr)
  35 import Foreign.Storable (Storable(..))
  36 import GHC.Base
  37 import GHC.Conc.Sync (withMVar)
  38 import GHC.Err (undefined)
  39 import GHC.Num (Num(..))
  40 import GHC.Real (ceiling, fromIntegral)
  41 import GHC.Show (Show)
  42 import System.Posix.Types (Fd(..))
  43
  44 import qualified System.Event.Array as A
  45 import qualified System.Event.Internal as E
  46
  47 available :: Bool
  48 available = True
  49 {-# INLINE available #-}
  50
  51 data Poll = Poll {
  52       pollChanges :: {-# UNPACK #-} !(MVar (A.Array PollFd))
  53     , pollFd      :: {-# UNPACK #-} !(A.Array PollFd)
  54     }
  55
  56 new :: IO E.Backend
  57 new = E.backend poll modifyFd (\_ -> return ()) `liftM`
  58       liftM2 Poll (newMVar =<< A.empty) A.empty
  59
  60 modifyFd :: Poll -> Fd -> E.Event -> E.Event -> IO ()
  61 modifyFd p fd oevt nevt =
  62   withMVar (pollChanges p) $ \ary ->
  63     A.snoc ary $ PollFd fd (fromEvent nevt) (fromEvent oevt)
  64
  65 reworkFd :: Poll -> PollFd -> IO ()
  66 reworkFd p (PollFd fd npevt opevt) = do
  67   let ary = pollFd p
  68   if opevt == 0
  69     then A.snoc ary $ PollFd fd npevt 0
  70     else do
  71       found <- A.findIndex ((== fd) . pfdFd) ary
  72       case found of
  73         Nothing        -> error "reworkFd: event not found"
  74         Just (i,_)
  75           | npevt /= 0 -> A.unsafeWrite ary i $ PollFd fd npevt 0
  76           | otherwise  -> A.removeAt ary i
  77
  78 poll :: Poll
  79      -> E.Timeout
  80      -> (Fd -> E.Event -> IO ())
  81      -> IO ()
  82 poll p tout f = do
  83   let a = pollFd p
  84   mods <- swapMVar (pollChanges p) =<< A.empty
  85   A.forM_ mods (reworkFd p)
  86   n <- A.useAsPtr a $ \ptr len -> E.throwErrnoIfMinus1NoRetry "c_poll" $
  87          c_poll ptr (fromIntegral len) (fromIntegral (fromTimeout tout))
  88   unless (n == 0) $ do
  89     A.loop a 0 $ \i e -> do
  90       let r = pfdRevents e
  91       if r /= 0
  92         then do f (pfdFd e) (toEvent r)
  93                 let i' = i + 1
  94                 return (i', i' == n)
  95         else return (i, True)
  96
  97 fromTimeout :: E.Timeout -> Int
  98 fromTimeout E.Forever     = -1
  99 fromTimeout (E.Timeout s) = ceiling $ 1000 * s
 100
 101 data PollFd = PollFd {
 102       pfdFd      :: {-# UNPACK #-} !Fd
 103     , pfdEvents  :: {-# UNPACK #-} !Event
 104     , pfdRevents :: {-# UNPACK #-} !Event
 105     } deriving (Show)
 106
 107 newtype Event = Event CShort
 108     deriving (Eq, Show, Num, Storable, Bits)
 109
 110 #{enum Event, Event
 111  , pollIn    = POLLIN
 112  , pollOut   = POLLOUT
 113 #ifdef POLLRDHUP
 114  , pollRdHup = POLLRDHUP
 115 #endif
 116  , pollErr   = POLLERR
 117  , pollHup   = POLLHUP
 118  }
 119
 120 fromEvent :: E.Event -> Event
 121 fromEvent e = remap E.evtRead  pollIn .|.
 122               remap E.evtWrite pollOut
 123   where remap evt to
 124             | e `E.eventIs` evt = to
 125             | otherwise         = 0
 126
 127 toEvent :: Event -> E.Event
 128 toEvent e = remap (pollIn .|. pollErr .|. pollHup)  E.evtRead `mappend`
 129             remap (pollOut .|. pollErr .|. pollHup) E.evtWrite
 130   where remap evt to
 131             | e .&. evt /= 0 = to
 132             | otherwise      = mempty
 133
 134 instance Storable PollFd where
 135     sizeOf _    = #size struct pollfd
 136     alignment _ = alignment (undefined :: CInt)
 137
 138     peek ptr = do
 139       fd <- #{peek struct pollfd, fd} ptr
 140       events <- #{peek struct pollfd, events} ptr
 141       revents <- #{peek struct pollfd, revents} ptr
 142       let !pollFd' = PollFd fd events revents
 143       return pollFd'
 144
 145     poke ptr p = do
 146       #{poke struct pollfd, fd} ptr (pfdFd p)
 147       #{poke struct pollfd, events} ptr (pfdEvents p)
 148       #{poke struct pollfd, revents} ptr (pfdRevents p)
 149
 150 foreign import ccall safe "poll.h poll"
 151     c_poll :: Ptr PollFd -> CULong -> CInt -> IO CInt
 152
 153 #endif /* defined(HAVE_POLL_H) */