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