Update base for latest Safe Haskell.
[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 <- getUSecOfDay
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 = startIOManagerThread
171 | otherwise = return ()
172
173 startIOManagerThread :: IO ()
174 startIOManagerThread = do
175 modifyMVar_ ioManagerThread $ \old -> do
176 let create = do t <- forkIO ioManager; return (Just t)
177 case old of
178 Nothing -> create
179 Just t -> do
180 s <- threadStatus t
181 case s of
182 ThreadFinished -> create
183 ThreadDied -> create
184 _other -> return (Just t)
185
186 insertDelay :: DelayReq -> [DelayReq] -> [DelayReq]
187 insertDelay d [] = [d]
188 insertDelay d1 ds@(d2 : rest)
189 | delayTime d1 <= delayTime d2 = d1 : ds
190 | otherwise = d2 : insertDelay d1 rest
191
192 delayTime :: DelayReq -> USecs
193 delayTime (Delay t _) = t
194 delayTime (DelaySTM t _) = t
195
196 type USecs = Word64
197
198 foreign import ccall unsafe "getUSecOfDay"
199 getUSecOfDay :: IO USecs
200
201 {-# NOINLINE prodding #-}
202 prodding :: IORef Bool
203 prodding = unsafePerformIO $ do
204 r <- newIORef False
205 sharedCAF r getOrSetGHCConcWindowsProddingStore
206
207 foreign import ccall unsafe "getOrSetGHCConcWindowsProddingStore"
208 getOrSetGHCConcWindowsProddingStore :: Ptr a -> IO (Ptr a)
209
210 prodServiceThread :: IO ()
211 prodServiceThread = do
212 -- NB. use atomicModifyIORef here, otherwise there are race
213 -- conditions in which prodding is left at True but the server is
214 -- blocked in select().
215 was_set <- atomicModifyIORef prodding $ \b -> (True,b)
216 unless was_set wakeupIOManager
217
218 -- ----------------------------------------------------------------------------
219 -- Windows IO manager thread
220
221 ioManager :: IO ()
222 ioManager = do
223 wakeup <- c_getIOManagerEvent
224 service_loop wakeup []
225
226 service_loop :: HANDLE -- read end of pipe
227 -> [DelayReq] -- current delay requests
228 -> IO ()
229
230 service_loop wakeup old_delays = do
231 -- pick up new delay requests
232 new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
233 let delays = foldr insertDelay old_delays new_delays
234
235 now <- getUSecOfDay
236 (delays', timeout) <- getDelay now delays
237
238 r <- c_WaitForSingleObject wakeup timeout
239 case r of
240 0xffffffff -> do throwGetLastError "service_loop"
241 0 -> do
242 r2 <- c_readIOManagerEvent
243 exit <-
244 case r2 of
245 _ | r2 == io_MANAGER_WAKEUP -> return False
246 _ | r2 == io_MANAGER_DIE -> return True
247 0 -> return False -- spurious wakeup
248 _ -> do start_console_handler (r2 `shiftR` 1); return False
249 unless exit $ service_cont wakeup delays'
250
251 _other -> service_cont wakeup delays' -- probably timeout
252
253 service_cont :: HANDLE -> [DelayReq] -> IO ()
254 service_cont wakeup delays = do
255 r <- atomicModifyIORef prodding (\_ -> (False,False))
256 r `seq` return () -- avoid space leak
257 service_loop wakeup delays
258
259 -- must agree with rts/win32/ThrIOManager.c
260 io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word32
261 io_MANAGER_WAKEUP = 0xffffffff
262 io_MANAGER_DIE = 0xfffffffe
263
264 data ConsoleEvent
265 = ControlC
266 | Break
267 | Close
268 -- these are sent to Services only.
269 | Logoff
270 | Shutdown
271 deriving (Eq, Ord, Enum, Show, Read, Typeable)
272
273 start_console_handler :: Word32 -> IO ()
274 start_console_handler r =
275 case toWin32ConsoleEvent r of
276 Just x -> withMVar win32ConsoleHandler $ \handler -> do
277 _ <- forkIO (handler x)
278 return ()
279 Nothing -> return ()
280
281 toWin32ConsoleEvent :: (Eq a, Num a) => a -> Maybe ConsoleEvent
282 toWin32ConsoleEvent ev =
283 case ev of
284 0 {- CTRL_C_EVENT-} -> Just ControlC
285 1 {- CTRL_BREAK_EVENT-} -> Just Break
286 2 {- CTRL_CLOSE_EVENT-} -> Just Close
287 5 {- CTRL_LOGOFF_EVENT-} -> Just Logoff
288 6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown
289 _ -> Nothing
290
291 win32ConsoleHandler :: MVar (ConsoleEvent -> IO ())
292 win32ConsoleHandler = unsafePerformIO (newMVar (error "win32ConsoleHandler"))
293
294 wakeupIOManager :: IO ()
295 wakeupIOManager = c_sendIOManagerEvent io_MANAGER_WAKEUP
296
297 -- Walk the queue of pending delays, waking up any that have passed
298 -- and return the smallest delay to wait for. The queue of pending
299 -- delays is kept ordered.
300 getDelay :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD)
301 getDelay _ [] = return ([], iNFINITE)
302 getDelay now all@(d : rest)
303 = case d of
304 Delay time m | now >= time -> do
305 putMVar m ()
306 getDelay now rest
307 DelaySTM time t | now >= time -> do
308 atomically $ writeTVar t True
309 getDelay now rest
310 _otherwise ->
311 -- delay is in millisecs for WaitForSingleObject
312 let micro_seconds = delayTime d - now
313 milli_seconds = (micro_seconds + 999) `div` 1000
314 in return (all, fromIntegral milli_seconds)
315
316 foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c)
317 c_getIOManagerEvent :: IO HANDLE
318
319 foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c)
320 c_readIOManagerEvent :: IO Word32
321
322 foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c)
323 c_sendIOManagerEvent :: Word32 -> IO ()
324
325 foreign import stdcall "WaitForSingleObject"
326 c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD
327