GHC/Event/Poll.hsc

   1 {-# LANGUAGE CPP
   2            , ForeignFunctionInterface
   3            , GeneralizedNewtypeDeriving
   4            , NoImplicitPrelude
   5            , BangPatterns
   6   #-}
   7
   8 module GHC.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 GHC.Event.Array as A
  45 import qualified GHC.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 -- We have to duplicate the whole enum like this in order for the
 111 -- hsc2hs cross-compilation mode to work
 112 #ifdef POLLRDHUP
 113 #{enum Event, Event
 114  , pollIn    = POLLIN
 115  , pollOut   = POLLOUT
 116  , pollRdHup = POLLRDHUP
 117  , pollErr   = POLLERR
 118  , pollHup   = POLLHUP
 119  }
 120 #else
 121 #{enum Event, Event
 122  , pollIn    = POLLIN
 123  , pollOut   = POLLOUT
 124  , pollErr   = POLLERR
 125  , pollHup   = POLLHUP
 126  }
 127 #endif
 128
 129 fromEvent :: E.Event -> Event
 130 fromEvent e = remap E.evtRead  pollIn .|.
 131               remap E.evtWrite pollOut
 132   where remap evt to
 133             | e `E.eventIs` evt = to
 134             | otherwise         = 0
 135
 136 toEvent :: Event -> E.Event
 137 toEvent e = remap (pollIn .|. pollErr .|. pollHup)  E.evtRead `mappend`
 138             remap (pollOut .|. pollErr .|. pollHup) E.evtWrite
 139   where remap evt to
 140             | e .&. evt /= 0 = to
 141             | otherwise      = mempty
 142
 143 instance Storable PollFd where
 144     sizeOf _    = #size struct pollfd
 145     alignment _ = alignment (undefined :: CInt)
 146
 147     peek ptr = do
 148       fd <- #{peek struct pollfd, fd} ptr
 149       events <- #{peek struct pollfd, events} ptr
 150       revents <- #{peek struct pollfd, revents} ptr
 151       let !pollFd' = PollFd fd events revents
 152       return pollFd'
 153
 154     poke ptr p = do
 155       #{poke struct pollfd, fd} ptr (pfdFd p)
 156       #{poke struct pollfd, events} ptr (pfdEvents p)
 157       #{poke struct pollfd, revents} ptr (pfdRevents p)
 158
 159 foreign import ccall safe "poll.h poll"
 160     c_poll :: Ptr PollFd -> CULong -> CInt -> IO CInt
 161
 162 #endif /* defined(HAVE_POLL_H) */