Fix potential `mingw32_HOST_OS` -Werror failure
[ghc.git] / libraries / base / GHC / Conc / Windows.hs
1 {-# LANGUAGE Trustworthy #-}
2 {-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples, AutoDeriveTypeable #-}
3 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
4 {-# OPTIONS_HADDOCK not-home #-}
5
6 -----------------------------------------------------------------------------
7 -- |
8 -- Module : GHC.Conc.Windows
9 -- Copyright : (c) The University of Glasgow, 1994-2002
10 -- License : see libraries/base/LICENSE
11 --
12 -- Maintainer : cvs-ghc@haskell.org
13 -- Stability : internal
14 -- Portability : non-portable (GHC extensions)
15 --
16 -- Windows I/O manager
17 --
18 -----------------------------------------------------------------------------
19
20 -- #not-home
21 module GHC.Conc.Windows
22 ( ensureIOManagerIsRunning
23
24 -- * Waiting
25 , threadDelay
26 , registerDelay
27
28 -- * Miscellaneous
29 , asyncRead
30 , asyncWrite
31 , asyncDoProc
32
33 , asyncReadBA
34 , asyncWriteBA
35
36 , ConsoleEvent(..)
37 , win32ConsoleHandler
38 , toWin32ConsoleEvent
39 ) where
40
41 import Control.Monad (unless)
42 import Data.Bits (shiftR)
43 import Data.Typeable
44 import GHC.Base
45 import GHC.Conc.Sync
46 import GHC.Enum (Enum)
47 import GHC.IO (unsafePerformIO)
48 import GHC.IORef
49 import GHC.MVar
50 import GHC.Num (Num(..))
51 import GHC.Ptr
52 import GHC.Read (Read)
53 import GHC.Real (div, fromIntegral)
54 import GHC.Show (Show)
55 import GHC.Word (Word32, Word64)
56 import GHC.Windows
57
58 #ifdef mingw32_HOST_OS
59 # if defined(i386_HOST_ARCH)
60 # define WINDOWS_CCONV stdcall
61 # elif defined(x86_64_HOST_ARCH)
62 # define WINDOWS_CCONV ccall
63 # else
64 # error Unknown mingw32 arch
65 # endif
66 #endif
67
68 -- ----------------------------------------------------------------------------
69 -- Thread waiting
70
71 -- Note: threadWaitRead and threadWaitWrite aren't really functional
72 -- on Win32, but left in there because lib code (still) uses them (the manner
73 -- in which they're used doesn't cause problems on a Win32 platform though.)
74
75 asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
76 asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) =
77 IO $ \s -> case asyncRead# fd isSock len buf s of
78 (# s', len#, err# #) -> (# s', (I# len#, I# err#) #)
79
80 asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
81 asyncWrite (I# fd) (I# isSock) (I# len) (Ptr buf) =
82 IO $ \s -> case asyncWrite# fd isSock len buf s of
83 (# s', len#, err# #) -> (# s', (I# len#, I# err#) #)
84
85 asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
86 asyncDoProc (FunPtr proc) (Ptr param) =
87 -- the 'length' value is ignored; simplifies implementation of
88 -- the async*# primops to have them all return the same result.
89 IO $ \s -> case asyncDoProc# proc param s of
90 (# s', _len#, err# #) -> (# s', I# err# #)
91
92 -- to aid the use of these primops by the IO Handle implementation,
93 -- provide the following convenience funs:
94
95 -- this better be a pinned byte array!
96 asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
97 asyncReadBA fd isSock len off bufB =
98 asyncRead fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
99
100 asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
101 asyncWriteBA fd isSock len off bufB =
102 asyncWrite fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
103
104 -- ----------------------------------------------------------------------------
105 -- Threaded RTS implementation of threadDelay
106
107 -- | Suspends the current thread for a given number of microseconds
108 -- (GHC only).
109 --
110 -- There is no guarantee that the thread will be rescheduled promptly
111 -- when the delay has expired, but the thread will never continue to
112 -- run /earlier/ than specified.
113 --
114 threadDelay :: Int -> IO ()
115 threadDelay time
116 | threaded = waitForDelayEvent time
117 | otherwise = IO $ \s ->
118 case time of { I# time# ->
119 case delay# time# s of { s' -> (# s', () #)
120 }}
121
122 -- | Set the value of returned TVar to True after a given number of
123 -- microseconds. The caveats associated with threadDelay also apply.
124 --
125 registerDelay :: Int -> IO (TVar Bool)
126 registerDelay usecs
127 | threaded = waitForDelayEventSTM usecs
128 | otherwise = error "registerDelay: requires -threaded"
129
130 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
131
132 waitForDelayEvent :: Int -> IO ()
133 waitForDelayEvent usecs = do
134 m <- newEmptyMVar
135 target <- calculateTarget usecs
136 atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ()))
137 prodServiceThread
138 takeMVar m
139
140 -- Delays for use in STM
141 waitForDelayEventSTM :: Int -> IO (TVar Bool)
142 waitForDelayEventSTM usecs = do
143 t <- atomically $ newTVar False
144 target <- calculateTarget usecs
145 atomicModifyIORef pendingDelays (\xs -> (DelaySTM target t : xs, ()))
146 prodServiceThread
147 return t
148
149 calculateTarget :: Int -> IO USecs
150 calculateTarget usecs = do
151 now <- getMonotonicUSec
152 return $ now + (fromIntegral usecs)
153
154 data DelayReq
155 = Delay {-# UNPACK #-} !USecs {-# UNPACK #-} !(MVar ())
156 | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool)
157
158 {-# NOINLINE pendingDelays #-}
159 pendingDelays :: IORef [DelayReq]
160 pendingDelays = unsafePerformIO $ do
161 m <- newIORef []
162 sharedCAF m getOrSetGHCConcWindowsPendingDelaysStore
163
164 foreign import ccall unsafe "getOrSetGHCConcWindowsPendingDelaysStore"
165 getOrSetGHCConcWindowsPendingDelaysStore :: Ptr a -> IO (Ptr a)
166
167 {-# NOINLINE ioManagerThread #-}
168 ioManagerThread :: MVar (Maybe ThreadId)
169 ioManagerThread = unsafePerformIO $ do
170 m <- newMVar Nothing
171 sharedCAF m getOrSetGHCConcWindowsIOManagerThreadStore
172
173 foreign import ccall unsafe "getOrSetGHCConcWindowsIOManagerThreadStore"
174 getOrSetGHCConcWindowsIOManagerThreadStore :: Ptr a -> IO (Ptr a)
175
176 ensureIOManagerIsRunning :: IO ()
177 ensureIOManagerIsRunning
178 | threaded = startIOManagerThread
179 | otherwise = return ()
180
181 startIOManagerThread :: IO ()
182 startIOManagerThread = do
183 modifyMVar_ ioManagerThread $ \old -> do
184 let create = do t <- forkIO ioManager; return (Just t)
185 case old of
186 Nothing -> create
187 Just t -> do
188 s <- threadStatus t
189 case s of
190 ThreadFinished -> create
191 ThreadDied -> create
192 _other -> return (Just t)
193
194 insertDelay :: DelayReq -> [DelayReq] -> [DelayReq]
195 insertDelay d [] = [d]
196 insertDelay d1 ds@(d2 : rest)
197 | delayTime d1 <= delayTime d2 = d1 : ds
198 | otherwise = d2 : insertDelay d1 rest
199
200 delayTime :: DelayReq -> USecs
201 delayTime (Delay t _) = t
202 delayTime (DelaySTM t _) = t
203
204 type USecs = Word64
205 type NSecs = Word64
206
207 foreign import ccall unsafe "getMonotonicNSec"
208 getMonotonicNSec :: IO NSecs
209
210 getMonotonicUSec :: IO USecs
211 getMonotonicUSec = fmap (`div` 1000) getMonotonicNSec
212
213 {-# NOINLINE prodding #-}
214 prodding :: IORef Bool
215 prodding = unsafePerformIO $ do
216 r <- newIORef False
217 sharedCAF r getOrSetGHCConcWindowsProddingStore
218
219 foreign import ccall unsafe "getOrSetGHCConcWindowsProddingStore"
220 getOrSetGHCConcWindowsProddingStore :: Ptr a -> IO (Ptr a)
221
222 prodServiceThread :: IO ()
223 prodServiceThread = do
224 -- NB. use atomicModifyIORef here, otherwise there are race
225 -- conditions in which prodding is left at True but the server is
226 -- blocked in select().
227 was_set <- atomicModifyIORef prodding $ \b -> (True,b)
228 unless was_set wakeupIOManager
229
230 -- ----------------------------------------------------------------------------
231 -- Windows IO manager thread
232
233 ioManager :: IO ()
234 ioManager = do
235 wakeup <- c_getIOManagerEvent
236 service_loop wakeup []
237
238 service_loop :: HANDLE -- read end of pipe
239 -> [DelayReq] -- current delay requests
240 -> IO ()
241
242 service_loop wakeup old_delays = do
243 -- pick up new delay requests
244 new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
245 let delays = foldr insertDelay old_delays new_delays
246
247 now <- getMonotonicUSec
248 (delays', timeout) <- getDelay now delays
249
250 r <- c_WaitForSingleObject wakeup timeout
251 case r of
252 0xffffffff -> do throwGetLastError "service_loop"
253 0 -> do
254 r2 <- c_readIOManagerEvent
255 exit <-
256 case r2 of
257 _ | r2 == io_MANAGER_WAKEUP -> return False
258 _ | r2 == io_MANAGER_DIE -> return True
259 0 -> return False -- spurious wakeup
260 _ -> do start_console_handler (r2 `shiftR` 1); return False
261 unless exit $ service_cont wakeup delays'
262
263 _other -> service_cont wakeup delays' -- probably timeout
264
265 service_cont :: HANDLE -> [DelayReq] -> IO ()
266 service_cont wakeup delays = do
267 r <- atomicModifyIORef prodding (\_ -> (False,False))
268 r `seq` return () -- avoid space leak
269 service_loop wakeup delays
270
271 -- must agree with rts/win32/ThrIOManager.c
272 io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word32
273 io_MANAGER_WAKEUP = 0xffffffff
274 io_MANAGER_DIE = 0xfffffffe
275
276 data ConsoleEvent
277 = ControlC
278 | Break
279 | Close
280 -- these are sent to Services only.
281 | Logoff
282 | Shutdown
283 deriving (Eq, Ord, Enum, Show, Read, Typeable)
284
285 start_console_handler :: Word32 -> IO ()
286 start_console_handler r =
287 case toWin32ConsoleEvent r of
288 Just x -> withMVar win32ConsoleHandler $ \handler -> do
289 _ <- forkIO (handler x)
290 return ()
291 Nothing -> return ()
292
293 toWin32ConsoleEvent :: (Eq a, Num a) => a -> Maybe ConsoleEvent
294 toWin32ConsoleEvent ev =
295 case ev of
296 0 {- CTRL_C_EVENT-} -> Just ControlC
297 1 {- CTRL_BREAK_EVENT-} -> Just Break
298 2 {- CTRL_CLOSE_EVENT-} -> Just Close
299 5 {- CTRL_LOGOFF_EVENT-} -> Just Logoff
300 6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown
301 _ -> Nothing
302
303 win32ConsoleHandler :: MVar (ConsoleEvent -> IO ())
304 win32ConsoleHandler = unsafePerformIO (newMVar (error "win32ConsoleHandler"))
305
306 wakeupIOManager :: IO ()
307 wakeupIOManager = c_sendIOManagerEvent io_MANAGER_WAKEUP
308
309 -- Walk the queue of pending delays, waking up any that have passed
310 -- and return the smallest delay to wait for. The queue of pending
311 -- delays is kept ordered.
312 getDelay :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD)
313 getDelay _ [] = return ([], iNFINITE)
314 getDelay now all@(d : rest)
315 = case d of
316 Delay time m | now >= time -> do
317 putMVar m ()
318 getDelay now rest
319 DelaySTM time t | now >= time -> do
320 atomically $ writeTVar t True
321 getDelay now rest
322 _otherwise ->
323 -- delay is in millisecs for WaitForSingleObject
324 let micro_seconds = delayTime d - now
325 milli_seconds = (micro_seconds + 999) `div` 1000
326 in return (all, fromIntegral milli_seconds)
327
328 foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c)
329 c_getIOManagerEvent :: IO HANDLE
330
331 foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c)
332 c_readIOManagerEvent :: IO Word32
333
334 foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c)
335 c_sendIOManagerEvent :: Word32 -> IO ()
336
337 foreign import WINDOWS_CCONV "WaitForSingleObject"
338 c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD
339