libraries/base/GHC/Event/Poll.hsc

   1 {-# LANGUAGE Trustworthy #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving
   3            , NoImplicitPrelude
   4            , BangPatterns
   5   #-}
   6
   7 module GHC.Event.Poll
   8     (
   9       new
  10     , available
  11     ) where
  12
  13 #include "EventConfig.h"
  14
  15 #if !defined(HAVE_POLL_H)
  16 import GHC.Base
  17
  18 new :: IO E.Backend
  19 new = error "Poll back end not implemented for this platform"
  20
  21 available :: Bool
  22 available = False
  23 {-# INLINE available #-}
  24 #else
  25 #include <poll.h>
  26
  27 import Control.Concurrent.MVar (MVar, newMVar, swapMVar)
  28 import Control.Monad ((=<<), liftM, liftM2, unless)
  29 import Data.Bits (Bits, (.|.), (.&.))
  30 import Data.Maybe (Maybe(..))
  31 import Data.Monoid (Monoid(..))
  32 import Data.Word
  33 import Foreign.C.Types (CInt(..), CShort(..))
  34 import Foreign.Ptr (Ptr)
  35 import Foreign.Storable (Storable(..))
  36 import GHC.Base
  37 import GHC.Conc.Sync (withMVar)
  38 import GHC.Enum (maxBound)
  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 modifyFdOnce (\_ -> return ()) `liftM`
  58       liftM2 Poll (newMVar =<< A.empty) A.empty
  59
  60 modifyFd :: Poll -> Fd -> E.Event -> E.Event -> IO Bool
  61 modifyFd p fd oevt nevt =
  62   withMVar (pollChanges p) $ \ary -> do
  63     A.snoc ary $ PollFd fd (fromEvent nevt) (fromEvent oevt)
  64     return True
  65
  66 modifyFdOnce :: Poll -> Fd -> E.Event -> IO Bool
  67 modifyFdOnce = error "modifyFdOnce not supported in Poll backend"
  68
  69 reworkFd :: Poll -> PollFd -> IO ()
  70 reworkFd p (PollFd fd npevt opevt) = do
  71   let ary = pollFd p
  72   if opevt == 0
  73     then A.snoc ary $ PollFd fd npevt 0
  74     else do
  75       found <- A.findIndex ((== fd) . pfdFd) ary
  76       case found of
  77         Nothing        -> error "reworkFd: event not found"
  78         Just (i,_)
  79           | npevt /= 0 -> A.unsafeWrite ary i $ PollFd fd npevt 0
  80           | otherwise  -> A.removeAt ary i
  81
  82 poll :: Poll
  83      -> Maybe E.Timeout
  84      -> (Fd -> E.Event -> IO ())
  85      -> IO Int
  86 poll p mtout f = do
  87   let a = pollFd p
  88   mods <- swapMVar (pollChanges p) =<< A.empty
  89   A.forM_ mods (reworkFd p)
  90   n <- A.useAsPtr a $ \ptr len ->
  91     E.throwErrnoIfMinus1NoRetry "c_poll" $
  92     case mtout of
  93       Just tout ->
  94         c_pollLoop ptr (fromIntegral len) (fromTimeout tout)
  95       Nothing   ->
  96         c_poll_unsafe ptr (fromIntegral len) 0
  97   unless (n == 0) $ do
  98     A.loop a 0 $ \i e -> do
  99       let r = pfdRevents e
 100       if r /= 0
 101         then do f (pfdFd e) (toEvent r)
 102                 let i' = i + 1
 103                 return (i', i' == n)
 104         else return (i, True)
 105   return (fromIntegral n)
 106   where
 107     -- The poll timeout is specified as an Int, but c_poll takes a CInt. These
 108     -- can't be safely coerced as on many systems (e.g. x86_64) CInt has a
 109     -- maxBound of (2^32 - 1), even though Int may have a significantly higher
 110     -- bound.
 111     --
 112     -- This function deals with timeouts greater than maxBound :: CInt, by
 113     -- looping until c_poll returns a non-zero value (0 indicates timeout
 114     -- expired) OR the full timeout has passed.
 115     c_pollLoop :: Ptr PollFd -> (#type nfds_t) -> Int -> IO CInt
 116     c_pollLoop ptr len tout
 117         | tout <= maxPollTimeout = c_poll ptr len (fromIntegral tout)
 118         | otherwise = do
 119             result <- c_poll ptr len (fromIntegral maxPollTimeout)
 120             if result == 0
 121                then c_pollLoop ptr len (fromIntegral (tout - maxPollTimeout))
 122                else return result
 123
 124     -- We need to account for 3 cases:
 125     --     1. Int and CInt are of equal size.
 126     --     2. Int is larger than CInt
 127     --     3. Int is smaller than CInt
 128     --
 129     -- In case 1, the value of maxPollTimeout will be the maxBound of Int.
 130     --
 131     -- In case 2, the value of maxPollTimeout will be the maxBound of CInt,
 132     -- which is the largest value accepted by c_poll. This will result in
 133     -- c_pollLoop recursing if the provided timeout is larger.
 134     --
 135     -- In case 3, "fromIntegral (maxBound :: CInt) :: Int" will result in a
 136     -- negative Int, max will thus return maxBound :: Int. Since poll doesn't
 137     -- accept values bigger than maxBound :: Int and CInt is larger than Int,
 138     -- there is no problem converting Int to CInt for the c_poll call.
 139     maxPollTimeout :: Int
 140     maxPollTimeout = max maxBound (fromIntegral (maxBound :: CInt))
 141
 142 fromTimeout :: E.Timeout -> Int
 143 fromTimeout E.Forever     = -1
 144 fromTimeout (E.Timeout s) = ceiling $ 1000 * s
 145
 146 data PollFd = PollFd {
 147       pfdFd      :: {-# UNPACK #-} !Fd
 148     , pfdEvents  :: {-# UNPACK #-} !Event
 149     , pfdRevents :: {-# UNPACK #-} !Event
 150     } deriving (Show)
 151
 152 newtype Event = Event CShort
 153     deriving (Eq, Show, Num, Storable, Bits)
 154
 155 -- We have to duplicate the whole enum like this in order for the
 156 -- hsc2hs cross-compilation mode to work
 157 #ifdef POLLRDHUP
 158 #{enum Event, Event
 159  , pollIn    = POLLIN
 160  , pollOut   = POLLOUT
 161  , pollRdHup = POLLRDHUP
 162  , pollErr   = POLLERR
 163  , pollHup   = POLLHUP
 164  }
 165 #else
 166 #{enum Event, Event
 167  , pollIn    = POLLIN
 168  , pollOut   = POLLOUT
 169  , pollErr   = POLLERR
 170  , pollHup   = POLLHUP
 171  }
 172 #endif
 173
 174 fromEvent :: E.Event -> Event
 175 fromEvent e = remap E.evtRead  pollIn .|.
 176               remap E.evtWrite pollOut
 177   where remap evt to
 178             | e `E.eventIs` evt = to
 179             | otherwise         = 0
 180
 181 toEvent :: Event -> E.Event
 182 toEvent e = remap (pollIn .|. pollErr .|. pollHup)  E.evtRead `mappend`
 183             remap (pollOut .|. pollErr .|. pollHup) E.evtWrite
 184   where remap evt to
 185             | e .&. evt /= 0 = to
 186             | otherwise      = mempty
 187
 188 instance Storable PollFd where
 189     sizeOf _    = #size struct pollfd
 190     alignment _ = alignment (undefined :: CInt)
 191
 192     peek ptr = do
 193       fd <- #{peek struct pollfd, fd} ptr
 194       events <- #{peek struct pollfd, events} ptr
 195       revents <- #{peek struct pollfd, revents} ptr
 196       let !pollFd' = PollFd fd events revents
 197       return pollFd'
 198
 199     poke ptr p = do
 200       #{poke struct pollfd, fd} ptr (pfdFd p)
 201       #{poke struct pollfd, events} ptr (pfdEvents p)
 202       #{poke struct pollfd, revents} ptr (pfdRevents p)
 203
 204 foreign import ccall safe "poll.h poll"
 205     c_poll :: Ptr PollFd -> (#type nfds_t) -> CInt -> IO CInt
 206
 207 foreign import ccall unsafe "poll.h poll"
 208     c_poll_unsafe :: Ptr PollFd -> (#type nfds_t) -> CInt -> IO CInt
 209 #endif /* defined(HAVE_POLL_H) */