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