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