System/Event/Poll.hsc

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