Spelling in comments
[ghc.git] / 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) */