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 Unsafe #-}
{-# LANGUAGE CPP
, NoImplicitPrelude
, ScopedTypeVariables
, BangPatterns
#-}
module GHC.Event.Control
(
-- * Managing the IO manager
Signal
, ControlMessage(..)
, Control
, newControl
, closeControl
-- ** Control message reception
, readControlMessage
-- *** File descriptors
, controlReadFd
, controlWriteFd
, wakeupReadFd
-- ** Control message sending
, sendWakeup
, sendDie
-- * Utilities
, setNonBlockingFD
) where
#include "EventConfig.h"
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 Foreign.C.Error (throwErrnoIfMinus1)
import Foreign.C.Types (CULLong(..))
#else
import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno)
#endif
data ControlMessage = CMsgWakeup
| CMsgDie !Foo
| 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
, didRegisterWakeupFd :: !Bool
} deriving (Show)
#if defined(HAVE_EVENTFD)
wakeupReadFd :: Control -> Fd
wakeupReadFd = controlEventFd
{-# INLINE wakeupReadFd #-}
#endif
-- | Create the structure (usually a pipe) used for waking up the IO
-- manager thread from another thread.
newControl :: Bool -> IO Control
newControl shouldRegister = 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.
setNonBlockingFD wr True
setCloseOnExec rd
setCloseOnExec wr
return (rd, wr)
(ctrl_rd, ctrl_wr) <- createPipe
#if defined(HAVE_EVENTFD)
ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0
setNonBlockingFD ev True
setCloseOnExec ev
when shouldRegister $ c_setIOManagerWakeupFd ev
#else
(wake_rd, wake_wr) <- createPipe
when shouldRegister $ 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
, didRegisterWakeupFd = shouldRegister
}
-- | Close the control structure used by the IO manager thread.
-- N.B. If this Control is the Control whose wakeup file was registered with
-- the RTS, then *BEFORE* the wakeup file is closed, we must call
-- c_setIOManagerWakeupFd (-1), so that the RTS does not try to use the wakeup
-- file after it has been closed.
closeControl :: Control -> IO ()
closeControl w = do
_ <- c_close . fromIntegral . controlReadFd $ w
_ <- c_close . fromIntegral . controlWriteFd $ w
when (didRegisterWakeupFd w) $ c_setIOManagerWakeupFd (-1)
#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 =
throwErrnoIfMinus1_ "sendWakeup" $
c_eventfd_write (fromIntegral (controlEventFd c)) 1
#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
foreign import ccall unsafe "sys/eventfd.h eventfd_write"
c_eventfd_write :: CInt -> CULLong -> IO CInt
#endif
foreign import ccall unsafe "setIOManagerWakeupFd"
c_setIOManagerWakeupFd :: CInt -> IO ()
|
