1 {-# OPTIONS_GHC -XNoImplicitPrelude #-}
2 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
3 {-# OPTIONS_HADDOCK not-home #-}
4 -----------------------------------------------------------------------------
6 -- Module : GHC.Conc.Windows
7 -- Copyright : (c) The University of Glasgow, 1994-2002
8 -- License : see libraries/base/LICENSE
10 -- Maintainer : cvs-ghc@haskell.org
11 -- Stability : internal
12 -- Portability : non-portable (GHC extensions)
14 -- Windows I/O manager
16 -----------------------------------------------------------------------------
19 module GHC.Conc.Windows
20 ( ensureIOManagerIsRunning
27 , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
28 , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
29 , asyncDoProc -- :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
31 , asyncReadBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
32 , asyncWriteBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
40 import Data.Bits (shiftR)
41 import Data.Maybe (Maybe(..))
43 import Foreign.C.Error (throwErrno)
46 import GHC.Enum (Enum)
47 import GHC.IO (unsafePerformIO)
50 import GHC.Num (Num(..))
52 import GHC.Read (Read)
53 import GHC.Real (div, fromIntegral)
54 import GHC.Show (Show)
55 import GHC.Word (Word32, Word64)
57 -- ----------------------------------------------------------------------------
60 -- Note: threadWaitRead and threadWaitWrite aren't really functional
61 -- on Win32, but left in there because lib code (still) uses them (the manner
62 -- in which they're used doesn't cause problems on a Win32 platform though.)
64 asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
65 asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) =
66 IO $ \s -> case asyncRead# fd isSock len buf s of
67 (# s', len#, err# #) -> (# s', (I# len#, I# err#) #)
69 asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
70 asyncWrite (I# fd) (I# isSock) (I# len) (Ptr buf) =
71 IO $ \s -> case asyncWrite# fd isSock len buf s of
72 (# s', len#, err# #) -> (# s', (I# len#, I# err#) #)
74 asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
75 asyncDoProc (FunPtr proc) (Ptr param) =
76 -- the 'length' value is ignored; simplifies implementation of
77 -- the async*# primops to have them all return the same result.
78 IO $ \s -> case asyncDoProc# proc param s of
79 (# s', _len#, err# #) -> (# s', I# err# #)
81 -- to aid the use of these primops by the IO Handle implementation,
82 -- provide the following convenience funs:
84 -- this better be a pinned byte array!
85 asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
86 asyncReadBA fd isSock len off bufB =
87 asyncRead fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
89 asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
90 asyncWriteBA fd isSock len off bufB =
91 asyncWrite fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
93 -- ----------------------------------------------------------------------------
94 -- Threaded RTS implementation of threadDelay
96 -- | Suspends the current thread for a given number of microseconds
99 -- There is no guarantee that the thread will be rescheduled promptly
100 -- when the delay has expired, but the thread will never continue to
101 -- run /earlier/ than specified.
103 threadDelay :: Int -> IO ()
105 | threaded = waitForDelayEvent time
106 | otherwise = IO $ \s ->
107 case fromIntegral time of { I# time# ->
108 case delay# time# s of { s' -> (# s', () #)
111 -- | Set the value of returned TVar to True after a given number of
112 -- microseconds. The caveats associated with threadDelay also apply.
114 registerDelay :: Int -> IO (TVar Bool)
116 | threaded = waitForDelayEventSTM usecs
117 | otherwise = error "registerDelay: requires -threaded"
119 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
121 waitForDelayEvent :: Int -> IO ()
122 waitForDelayEvent usecs = do
124 target <- calculateTarget usecs
125 atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ()))
129 -- Delays for use in STM
130 waitForDelayEventSTM :: Int -> IO (TVar Bool)
131 waitForDelayEventSTM usecs = do
132 t <- atomically $ newTVar False
133 target <- calculateTarget usecs
134 atomicModifyIORef pendingDelays (\xs -> (DelaySTM target t : xs, ()))
138 calculateTarget :: Int -> IO USecs
139 calculateTarget usecs = do
141 return $ now + (fromIntegral usecs)
144 = Delay {-# UNPACK #-} !USecs {-# UNPACK #-} !(MVar ())
145 | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool)
147 {-# NOINLINE pendingDelays #-}
148 pendingDelays :: IORef [DelayReq]
149 pendingDelays = unsafePerformIO $ do
151 sharedCAF m getOrSetGHCConcWindowsPendingDelaysStore
153 foreign import ccall unsafe "getOrSetGHCConcWindowsPendingDelaysStore"
154 getOrSetGHCConcWindowsPendingDelaysStore :: Ptr a -> IO (Ptr a)
156 {-# NOINLINE ioManagerThread #-}
157 ioManagerThread :: MVar (Maybe ThreadId)
158 ioManagerThread = unsafePerformIO $ do
160 sharedCAF m getOrSetGHCConcWindowsIOManagerThreadStore
162 foreign import ccall unsafe "getOrSetGHCConcWindowsIOManagerThreadStore"
163 getOrSetGHCConcWindowsIOManagerThreadStore :: Ptr a -> IO (Ptr a)
165 ensureIOManagerIsRunning :: IO ()
166 ensureIOManagerIsRunning
167 | threaded = startIOManagerThread
168 | otherwise = return ()
170 startIOManagerThread :: IO ()
171 startIOManagerThread = do
172 modifyMVar_ ioManagerThread $ \old -> do
173 let create = do t <- forkIO ioManager; return (Just t)
179 ThreadFinished -> create
181 _other -> return (Just t)
183 insertDelay :: DelayReq -> [DelayReq] -> [DelayReq]
184 insertDelay d [] = [d]
185 insertDelay d1 ds@(d2 : rest)
186 | delayTime d1 <= delayTime d2 = d1 : ds
187 | otherwise = d2 : insertDelay d1 rest
189 delayTime :: DelayReq -> USecs
190 delayTime (Delay t _) = t
191 delayTime (DelaySTM t _) = t
195 foreign import ccall unsafe "getUSecOfDay"
196 getUSecOfDay :: IO USecs
198 {-# NOINLINE prodding #-}
199 prodding :: IORef Bool
200 prodding = unsafePerformIO $ do
202 sharedCAF r getOrSetGHCConcWindowsProddingStore
204 foreign import ccall unsafe "getOrSetGHCConcWindowsProddingStore"
205 getOrSetGHCConcWindowsProddingStore :: Ptr a -> IO (Ptr a)
207 prodServiceThread :: IO ()
208 prodServiceThread = do
209 -- NB. use atomicModifyIORef here, otherwise there are race
210 -- conditions in which prodding is left at True but the server is
211 -- blocked in select().
212 was_set <- atomicModifyIORef prodding $ \b -> (True,b)
213 unless was_set wakeupIOManager
215 -- ----------------------------------------------------------------------------
216 -- Windows IO manager thread
220 wakeup <- c_getIOManagerEvent
221 service_loop wakeup []
223 service_loop :: HANDLE -- read end of pipe
224 -> [DelayReq] -- current delay requests
227 service_loop wakeup old_delays = do
228 -- pick up new delay requests
229 new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
230 let delays = foldr insertDelay old_delays new_delays
233 (delays', timeout) <- getDelay now delays
235 r <- c_WaitForSingleObject wakeup timeout
237 0xffffffff -> do c_maperrno; throwErrno "service_loop"
239 r2 <- c_readIOManagerEvent
242 _ | r2 == io_MANAGER_WAKEUP -> return False
243 _ | r2 == io_MANAGER_DIE -> return True
244 0 -> return False -- spurious wakeup
245 _ -> do start_console_handler (r2 `shiftR` 1); return False
246 unless exit $ service_cont wakeup delays'
248 _other -> service_cont wakeup delays' -- probably timeout
250 service_cont :: HANDLE -> [DelayReq] -> IO ()
251 service_cont wakeup delays = do
252 r <- atomicModifyIORef prodding (\_ -> (False,False))
253 r `seq` return () -- avoid space leak
254 service_loop wakeup delays
256 -- must agree with rts/win32/ThrIOManager.c
257 io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word32
258 io_MANAGER_WAKEUP = 0xffffffff
259 io_MANAGER_DIE = 0xfffffffe
265 -- these are sent to Services only.
268 deriving (Eq, Ord, Enum, Show, Read, Typeable)
270 start_console_handler :: Word32 -> IO ()
271 start_console_handler r =
272 case toWin32ConsoleEvent r of
273 Just x -> withMVar win32ConsoleHandler $ \handler -> do
274 _ <- forkIO (handler x)
278 toWin32ConsoleEvent :: Num a => a -> Maybe ConsoleEvent
279 toWin32ConsoleEvent ev =
281 0 {- CTRL_C_EVENT-} -> Just ControlC
282 1 {- CTRL_BREAK_EVENT-} -> Just Break
283 2 {- CTRL_CLOSE_EVENT-} -> Just Close
284 5 {- CTRL_LOGOFF_EVENT-} -> Just Logoff
285 6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown
288 win32ConsoleHandler :: MVar (ConsoleEvent -> IO ())
289 win32ConsoleHandler = unsafePerformIO (newMVar (error "win32ConsoleHandler"))
291 wakeupIOManager :: IO ()
292 wakeupIOManager = c_sendIOManagerEvent io_MANAGER_WAKEUP
294 -- Walk the queue of pending delays, waking up any that have passed
295 -- and return the smallest delay to wait for. The queue of pending
296 -- delays is kept ordered.
297 getDelay :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD)
298 getDelay _ [] = return ([], iNFINITE)
299 getDelay now all@(d : rest)
301 Delay time m | now >= time -> do
304 DelaySTM time t | now >= time -> do
305 atomically $ writeTVar t True
308 -- delay is in millisecs for WaitForSingleObject
309 let micro_seconds = delayTime d - now
310 milli_seconds = (micro_seconds + 999) `div` 1000
311 in return (all, fromIntegral milli_seconds)
313 -- ToDo: this just duplicates part of System.Win32.Types, which isn't
314 -- available yet. We should move some Win32 functionality down here,
315 -- maybe as part of the grand reorganisation of the base package...
320 iNFINITE = 0xFFFFFFFF -- urgh
322 foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c)
323 c_getIOManagerEvent :: IO HANDLE
325 foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c)
326 c_readIOManagerEvent :: IO Word32
328 foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c)
329 c_sendIOManagerEvent :: Word32 -> IO ()
331 foreign import ccall unsafe "maperrno" -- in Win32Utils.c
334 foreign import stdcall "WaitForSingleObject"
335 c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD