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
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
|
{-# LANGUAGE CPP, ForeignFunctionInterface, NoImplicitPrelude,
ScopedTypeVariables #-}
module System.Event.Control
(
-- * Managing the IO manager
Signal
, ControlMessage(..)
, Control
, newControl
, closeControl
-- ** Control message reception
, readControlMessage
-- *** File descriptors
, controlReadFd
, wakeupReadFd
-- ** Control message sending
, sendWakeup
, sendDie
-- * Utilities
, setNonBlockingFD
) where
#include "EventConfig.h"
import Control.Monad (when)
import Foreign.ForeignPtr (ForeignPtr)
import GHC.Base
import GHC.Conc.Signal (Signal)
import GHC.Real (fromIntegral)
import GHC.Show (Show)
import GHC.Word (Word8)
import Foreign.C.Error (throwErrnoIfMinus1_)
import Foreign.C.Types (CInt, CSize)
import Foreign.ForeignPtr (mallocForeignPtrBytes, withForeignPtr)
import Foreign.Marshal (alloca, allocaBytes)
import Foreign.Marshal.Array (allocaArray)
import Foreign.Ptr (castPtr)
import Foreign.Storable (peek, peekElemOff, poke)
import System.Posix.Internals (c_close, c_pipe, c_read, c_write,
setCloseOnExec, setNonBlockingFD)
import System.Posix.Types (Fd)
#if defined(HAVE_EVENTFD)
import Data.Word (Word64)
import Foreign.C.Error (throwErrnoIfMinus1)
#else
import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno)
#endif
data ControlMessage = CMsgWakeup
| CMsgDie
| CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8)
{-# UNPACK #-} !Signal
deriving (Eq, Show)
-- | The structure used to tell the IO manager thread what to do.
data Control = W {
controlReadFd :: {-# UNPACK #-} !Fd
, controlWriteFd :: {-# UNPACK #-} !Fd
#if defined(HAVE_EVENTFD)
, controlEventFd :: {-# UNPACK #-} !Fd
#else
, wakeupReadFd :: {-# UNPACK #-} !Fd
, wakeupWriteFd :: {-# UNPACK #-} !Fd
#endif
} deriving (Show)
#if defined(HAVE_EVENTFD)
wakeupReadFd :: Control -> Fd
wakeupReadFd = controlEventFd
{-# INLINE wakeupReadFd #-}
#endif
setNonBlock :: CInt -> IO ()
setNonBlock fd =
#if __GLASGOW_HASKELL__ >= 611
setNonBlockingFD fd True
#else
setNonBlockingFD fd
#endif
-- | Create the structure (usually a pipe) used for waking up the IO
-- manager thread from another thread.
newControl :: IO Control
newControl = allocaArray 2 $ \fds -> do
let createPipe = do
throwErrnoIfMinus1_ "pipe" $ c_pipe fds
rd <- peekElemOff fds 0
wr <- peekElemOff fds 1
-- The write end must be non-blocking, since we may need to
-- poke the event manager from a signal handler.
setNonBlock wr
setCloseOnExec rd
setCloseOnExec wr
return (rd, wr)
(ctrl_rd, ctrl_wr) <- createPipe
c_setIOManagerControlFd ctrl_wr
#if defined(HAVE_EVENTFD)
ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0
setNonBlock ev
setCloseOnExec ev
c_setIOManagerWakeupFd ev
#else
(wake_rd, wake_wr) <- createPipe
c_setIOManagerWakeupFd wake_wr
#endif
return W { controlReadFd = fromIntegral ctrl_rd
, controlWriteFd = fromIntegral ctrl_wr
#if defined(HAVE_EVENTFD)
, controlEventFd = fromIntegral ev
#else
, wakeupReadFd = fromIntegral wake_rd
, wakeupWriteFd = fromIntegral wake_wr
#endif
}
-- | Close the control structure used by the IO manager thread.
closeControl :: Control -> IO ()
closeControl w = do
_ <- c_close . fromIntegral . controlReadFd $ w
_ <- c_close . fromIntegral . controlWriteFd $ w
#if defined(HAVE_EVENTFD)
_ <- c_close . fromIntegral . controlEventFd $ w
#else
_ <- c_close . fromIntegral . wakeupReadFd $ w
_ <- c_close . fromIntegral . wakeupWriteFd $ w
#endif
return ()
io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8
io_MANAGER_WAKEUP = 0xff
io_MANAGER_DIE = 0xfe
foreign import ccall "__hscore_sizeof_siginfo_t"
sizeof_siginfo_t :: CSize
readControlMessage :: Control -> Fd -> IO ControlMessage
readControlMessage ctrl fd
| fd == wakeupReadFd ctrl = allocaBytes wakeupBufferSize $ \p -> do
throwErrnoIfMinus1_ "readWakeupMessage" $
c_read (fromIntegral fd) p (fromIntegral wakeupBufferSize)
return CMsgWakeup
| otherwise =
alloca $ \p -> do
throwErrnoIfMinus1_ "readControlMessage" $
c_read (fromIntegral fd) p 1
s <- peek p
case s of
-- Wakeup messages shouldn't be sent on the control
-- file descriptor but we handle them anyway.
_ | s == io_MANAGER_WAKEUP -> return CMsgWakeup
_ | s == io_MANAGER_DIE -> return CMsgDie
_ -> do -- Signal
fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)
withForeignPtr fp $ \p_siginfo -> do
r <- c_read (fromIntegral fd) (castPtr p_siginfo)
sizeof_siginfo_t
when (r /= fromIntegral sizeof_siginfo_t) $
error "failed to read siginfo_t"
let !s' = fromIntegral s
return $ CMsgSignal fp s'
where wakeupBufferSize =
#if defined(HAVE_EVENTFD)
8
#else
4096
#endif
sendWakeup :: Control -> IO ()
#if defined(HAVE_EVENTFD)
sendWakeup c = alloca $ \p -> do
poke p (1 :: Word64)
throwErrnoIfMinus1_ "sendWakeup" $
c_write (fromIntegral (controlEventFd c)) (castPtr p) 8
#else
sendWakeup c = do
n <- sendMessage (wakeupWriteFd c) CMsgWakeup
case n of
_ | n /= -1 -> return ()
| otherwise -> do
errno <- getErrno
when (errno /= eAGAIN && errno /= eWOULDBLOCK) $
throwErrno "sendWakeup"
#endif
sendDie :: Control -> IO ()
sendDie c = throwErrnoIfMinus1_ "sendDie" $
sendMessage (controlWriteFd c) CMsgDie
sendMessage :: Fd -> ControlMessage -> IO Int
sendMessage fd msg = alloca $ \p -> do
case msg of
CMsgWakeup -> poke p io_MANAGER_WAKEUP
CMsgDie -> poke p io_MANAGER_DIE
CMsgSignal _fp _s -> error "Signals can only be sent from within the RTS"
fromIntegral `fmap` c_write (fromIntegral fd) p 1
#if defined(HAVE_EVENTFD)
foreign import ccall unsafe "sys/eventfd.h eventfd"
c_eventfd :: CInt -> CInt -> IO CInt
#endif
-- Used to tell the RTS how it can send messages to the I/O manager.
foreign import ccall "setIOManagerControlFd"
c_setIOManagerControlFd :: CInt -> IO ()
foreign import ccall "setIOManagerWakeupFd"
c_setIOManagerWakeupFd :: CInt -> IO ()
|
