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