RTS/IOManager: fix trac issue #9722.
[ghc.git] / libraries / base / GHC / Event / Control.hs
1 {-# LANGUAGE Unsafe #-}
2 {-# LANGUAGE CPP
3 , NoImplicitPrelude
4 , ScopedTypeVariables
5 , BangPatterns
6 #-}
7
8 module GHC.Event.Control
9 (
10 -- * Managing the IO manager
11 Signal
12 , ControlMessage(..)
13 , Control
14 , newControl
15 , closeControl
16 -- ** Control message reception
17 , readControlMessage
18 -- *** File descriptors
19 , controlReadFd
20 , controlWriteFd
21 , wakeupReadFd
22 -- ** Control message sending
23 , sendWakeup
24 , sendDie
25 -- * Utilities
26 , setNonBlockingFD
27 ) where
28
29 #include "EventConfig.h"
30
31 import Foreign.ForeignPtr (ForeignPtr)
32 import GHC.Base
33 import GHC.Conc.Signal (Signal)
34 import GHC.Real (fromIntegral)
35 import GHC.Show (Show)
36 import GHC.Word (Word8)
37 import Foreign.C.Error (throwErrnoIfMinus1_)
38 import Foreign.C.Types (CInt(..), CSize(..))
39 import Foreign.ForeignPtr (mallocForeignPtrBytes, withForeignPtr)
40 import Foreign.Marshal (alloca, allocaBytes)
41 import Foreign.Marshal.Array (allocaArray)
42 import Foreign.Ptr (castPtr)
43 import Foreign.Storable (peek, peekElemOff, poke)
44 import System.Posix.Internals (c_close, c_pipe, c_read, c_write,
45 setCloseOnExec, setNonBlockingFD)
46 import System.Posix.Types (Fd)
47
48 #if defined(HAVE_EVENTFD)
49 import Foreign.C.Error (throwErrnoIfMinus1)
50 import Foreign.C.Types (CULLong(..))
51 #else
52 import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno)
53 #endif
54
55 data ControlMessage = CMsgWakeup
56 | CMsgDie
57 | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8)
58 {-# UNPACK #-} !Signal
59 deriving (Eq, Show)
60
61 -- | The structure used to tell the IO manager thread what to do.
62 data Control = W {
63 controlReadFd :: {-# UNPACK #-} !Fd
64 , controlWriteFd :: {-# UNPACK #-} !Fd
65 #if defined(HAVE_EVENTFD)
66 , controlEventFd :: {-# UNPACK #-} !Fd
67 #else
68 , wakeupReadFd :: {-# UNPACK #-} !Fd
69 , wakeupWriteFd :: {-# UNPACK #-} !Fd
70 #endif
71 , didRegisterWakeupFd :: !Bool
72 } deriving (Show)
73
74 #if defined(HAVE_EVENTFD)
75 wakeupReadFd :: Control -> Fd
76 wakeupReadFd = controlEventFd
77 {-# INLINE wakeupReadFd #-}
78 #endif
79
80 -- | Create the structure (usually a pipe) used for waking up the IO
81 -- manager thread from another thread.
82 newControl :: Bool -> IO Control
83 newControl shouldRegister = allocaArray 2 $ \fds -> do
84 let createPipe = do
85 throwErrnoIfMinus1_ "pipe" $ c_pipe fds
86 rd <- peekElemOff fds 0
87 wr <- peekElemOff fds 1
88 -- The write end must be non-blocking, since we may need to
89 -- poke the event manager from a signal handler.
90 setNonBlockingFD wr True
91 setCloseOnExec rd
92 setCloseOnExec wr
93 return (rd, wr)
94 (ctrl_rd, ctrl_wr) <- createPipe
95 #if defined(HAVE_EVENTFD)
96 ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0
97 setNonBlockingFD ev True
98 setCloseOnExec ev
99 when shouldRegister $ c_setIOManagerWakeupFd ev
100 #else
101 (wake_rd, wake_wr) <- createPipe
102 when shouldRegister $ c_setIOManagerWakeupFd wake_wr
103 #endif
104 return W { controlReadFd = fromIntegral ctrl_rd
105 , controlWriteFd = fromIntegral ctrl_wr
106 #if defined(HAVE_EVENTFD)
107 , controlEventFd = fromIntegral ev
108 #else
109 , wakeupReadFd = fromIntegral wake_rd
110 , wakeupWriteFd = fromIntegral wake_wr
111 #endif
112 , didRegisterWakeupFd = shouldRegister
113 }
114
115 -- | Close the control structure used by the IO manager thread.
116 -- N.B. If this Control is the Control whose wakeup file was registered with
117 -- the RTS, then *BEFORE* the wakeup file is closed, we must call
118 -- c_setIOManagerWakeupFd (-1), so that the RTS does not try to use the wakeup
119 -- file after it has been closed.
120 closeControl :: Control -> IO ()
121 closeControl w = do
122 _ <- c_close . fromIntegral . controlReadFd $ w
123 _ <- c_close . fromIntegral . controlWriteFd $ w
124 when (didRegisterWakeupFd w) $ c_setIOManagerWakeupFd (-1)
125 #if defined(HAVE_EVENTFD)
126 _ <- c_close . fromIntegral . controlEventFd $ w
127 #else
128 _ <- c_close . fromIntegral . wakeupReadFd $ w
129 _ <- c_close . fromIntegral . wakeupWriteFd $ w
130 #endif
131 return ()
132
133 io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8
134 io_MANAGER_WAKEUP = 0xff
135 io_MANAGER_DIE = 0xfe
136
137 foreign import ccall "__hscore_sizeof_siginfo_t"
138 sizeof_siginfo_t :: CSize
139
140 readControlMessage :: Control -> Fd -> IO ControlMessage
141 readControlMessage ctrl fd
142 | fd == wakeupReadFd ctrl = allocaBytes wakeupBufferSize $ \p -> do
143 throwErrnoIfMinus1_ "readWakeupMessage" $
144 c_read (fromIntegral fd) p (fromIntegral wakeupBufferSize)
145 return CMsgWakeup
146 | otherwise =
147 alloca $ \p -> do
148 throwErrnoIfMinus1_ "readControlMessage" $
149 c_read (fromIntegral fd) p 1
150 s <- peek p
151 case s of
152 -- Wakeup messages shouldn't be sent on the control
153 -- file descriptor but we handle them anyway.
154 _ | s == io_MANAGER_WAKEUP -> return CMsgWakeup
155 _ | s == io_MANAGER_DIE -> return CMsgDie
156 _ -> do -- Signal
157 fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)
158 withForeignPtr fp $ \p_siginfo -> do
159 r <- c_read (fromIntegral fd) (castPtr p_siginfo)
160 sizeof_siginfo_t
161 when (r /= fromIntegral sizeof_siginfo_t) $
162 error "failed to read siginfo_t"
163 let !s' = fromIntegral s
164 return $ CMsgSignal fp s'
165
166 where wakeupBufferSize =
167 #if defined(HAVE_EVENTFD)
168 8
169 #else
170 4096
171 #endif
172
173 sendWakeup :: Control -> IO ()
174 #if defined(HAVE_EVENTFD)
175 sendWakeup c =
176 throwErrnoIfMinus1_ "sendWakeup" $
177 c_eventfd_write (fromIntegral (controlEventFd c)) 1
178 #else
179 sendWakeup c = do
180 n <- sendMessage (wakeupWriteFd c) CMsgWakeup
181 case n of
182 _ | n /= -1 -> return ()
183 | otherwise -> do
184 errno <- getErrno
185 when (errno /= eAGAIN && errno /= eWOULDBLOCK) $
186 throwErrno "sendWakeup"
187 #endif
188
189 sendDie :: Control -> IO ()
190 sendDie c = throwErrnoIfMinus1_ "sendDie" $
191 sendMessage (controlWriteFd c) CMsgDie
192
193 sendMessage :: Fd -> ControlMessage -> IO Int
194 sendMessage fd msg = alloca $ \p -> do
195 case msg of
196 CMsgWakeup -> poke p io_MANAGER_WAKEUP
197 CMsgDie -> poke p io_MANAGER_DIE
198 CMsgSignal _fp _s -> error "Signals can only be sent from within the RTS"
199 fromIntegral `fmap` c_write (fromIntegral fd) p 1
200
201 #if defined(HAVE_EVENTFD)
202 foreign import ccall unsafe "sys/eventfd.h eventfd"
203 c_eventfd :: CInt -> CInt -> IO CInt
204
205 foreign import ccall unsafe "sys/eventfd.h eventfd_write"
206 c_eventfd_write :: CInt -> CULLong -> IO CInt
207 #endif
208
209 foreign import ccall unsafe "setIOManagerWakeupFd"
210 c_setIOManagerWakeupFd :: CInt -> IO ()