1 {-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, ForeignFunctionInterface,
3 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
4 {-# OPTIONS_HADDOCK not-home #-}
6 -----------------------------------------------------------------------------
8 -- Module : GHC.Conc.Windows
9 -- Copyright : (c) The University of Glasgow, 1994-2002
10 -- License : see libraries/base/LICENSE
12 -- Maintainer : cvs-ghc@haskell.org
13 -- Stability : internal
14 -- Portability : non-portable (GHC extensions)
16 -- Windows I/O manager
18 -----------------------------------------------------------------------------
21 module GHC.Conc.Windows
22 ( ensureIOManagerIsRunning
29 , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
30 , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
31 , asyncDoProc -- :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
33 , asyncReadBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
34 , asyncWriteBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
42 import Data.Bits (shiftR)
43 import Data.Maybe (Maybe(..))
47 import GHC.Enum (Enum)
48 import GHC.IO (unsafePerformIO)
51 import GHC.Num (Num(..))
53 import GHC.Read (Read)
54 import GHC.Real (div, fromIntegral)
55 import GHC.Show (Show)
56 import GHC.Word (Word32, Word64)
59 -- ----------------------------------------------------------------------------
62 -- Note: threadWaitRead and threadWaitWrite aren't really functional
63 -- on Win32, but left in there because lib code (still) uses them (the manner
64 -- in which they're used doesn't cause problems on a Win32 platform though.)
66 asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
67 asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) =
68 IO $ \s -> case asyncRead# fd isSock len buf s of
69 (# s', len#, err# #) -> (# s', (I# len#, I# err#) #)
71 asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
72 asyncWrite (I# fd) (I# isSock) (I# len) (Ptr buf) =
73 IO $ \s -> case asyncWrite# fd isSock len buf s of
74 (# s', len#, err# #) -> (# s', (I# len#, I# err#) #)
76 asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
77 asyncDoProc (FunPtr proc) (Ptr param) =
78 -- the 'length' value is ignored; simplifies implementation of
79 -- the async*# primops to have them all return the same result.
80 IO $ \s -> case asyncDoProc# proc param s of
81 (# s', _len#, err# #) -> (# s', I# err# #)
83 -- to aid the use of these primops by the IO Handle implementation,
84 -- provide the following convenience funs:
86 -- this better be a pinned byte array!
87 asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
88 asyncReadBA fd isSock len off bufB =
89 asyncRead fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
91 asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
92 asyncWriteBA fd isSock len off bufB =
93 asyncWrite fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
95 -- ----------------------------------------------------------------------------
96 -- Threaded RTS implementation of threadDelay
98 -- | Suspends the current thread for a given number of microseconds
101 -- There is no guarantee that the thread will be rescheduled promptly
102 -- when the delay has expired, but the thread will never continue to
103 -- run /earlier/ than specified.
105 threadDelay :: Int -> IO ()
107 | threaded = waitForDelayEvent time
108 | otherwise = IO $ \s ->
109 case time of { I# time# ->
110 case delay# time# s of { s' -> (# s', () #)
113 -- | Set the value of returned TVar to True after a given number of
114 -- microseconds. The caveats associated with threadDelay also apply.
116 registerDelay :: Int -> IO (TVar Bool)
118 | threaded = waitForDelayEventSTM usecs
119 | otherwise = error "registerDelay: requires -threaded"
121 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
123 waitForDelayEvent :: Int -> IO ()
124 waitForDelayEvent usecs = do
126 target <- calculateTarget usecs
127 atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ()))
131 -- Delays for use in STM
132 waitForDelayEventSTM :: Int -> IO (TVar Bool)
133 waitForDelayEventSTM usecs = do
134 t <- atomically $ newTVar False
135 target <- calculateTarget usecs
136 atomicModifyIORef pendingDelays (\xs -> (DelaySTM target t : xs, ()))
140 calculateTarget :: Int -> IO USecs
141 calculateTarget usecs = do
143 return $ now + (fromIntegral usecs)
146 = Delay {-# UNPACK #-} !USecs {-# UNPACK #-} !(MVar ())
147 | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool)
149 {-# NOINLINE pendingDelays #-}
150 pendingDelays :: IORef [DelayReq]
151 pendingDelays = unsafePerformIO $ do
153 sharedCAF m getOrSetGHCConcWindowsPendingDelaysStore
155 foreign import ccall unsafe "getOrSetGHCConcWindowsPendingDelaysStore"
156 getOrSetGHCConcWindowsPendingDelaysStore :: Ptr a -> IO (Ptr a)
158 {-# NOINLINE ioManagerThread #-}
159 ioManagerThread :: MVar (Maybe ThreadId)
160 ioManagerThread = unsafePerformIO $ do
162 sharedCAF m getOrSetGHCConcWindowsIOManagerThreadStore
164 foreign import ccall unsafe "getOrSetGHCConcWindowsIOManagerThreadStore"
165 getOrSetGHCConcWindowsIOManagerThreadStore :: Ptr a -> IO (Ptr a)
167 ensureIOManagerIsRunning :: IO ()
168 ensureIOManagerIsRunning
169 | threaded = startIOManagerThread
170 | otherwise = return ()
172 startIOManagerThread :: IO ()
173 startIOManagerThread = do
174 modifyMVar_ ioManagerThread $ \old -> do
175 let create = do t <- forkIO ioManager; return (Just t)
181 ThreadFinished -> create
183 _other -> return (Just t)
185 insertDelay :: DelayReq -> [DelayReq] -> [DelayReq]
186 insertDelay d [] = [d]
187 insertDelay d1 ds@(d2 : rest)
188 | delayTime d1 <= delayTime d2 = d1 : ds
189 | otherwise = d2 : insertDelay d1 rest
191 delayTime :: DelayReq -> USecs
192 delayTime (Delay t _) = t
193 delayTime (DelaySTM t _) = t
197 foreign import ccall unsafe "getUSecOfDay"
198 getUSecOfDay :: IO USecs
200 {-# NOINLINE prodding #-}
201 prodding :: IORef Bool
202 prodding = unsafePerformIO $ do
204 sharedCAF r getOrSetGHCConcWindowsProddingStore
206 foreign import ccall unsafe "getOrSetGHCConcWindowsProddingStore"
207 getOrSetGHCConcWindowsProddingStore :: Ptr a -> IO (Ptr a)
209 prodServiceThread :: IO ()
210 prodServiceThread = do
211 -- NB. use atomicModifyIORef here, otherwise there are race
212 -- conditions in which prodding is left at True but the server is
213 -- blocked in select().
214 was_set <- atomicModifyIORef prodding $ \b -> (True,b)
215 unless was_set wakeupIOManager
217 -- ----------------------------------------------------------------------------
218 -- Windows IO manager thread
222 wakeup <- c_getIOManagerEvent
223 service_loop wakeup []
225 service_loop :: HANDLE -- read end of pipe
226 -> [DelayReq] -- current delay requests
229 service_loop wakeup old_delays = do
230 -- pick up new delay requests
231 new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
232 let delays = foldr insertDelay old_delays new_delays
235 (delays', timeout) <- getDelay now delays
237 r <- c_WaitForSingleObject wakeup timeout
239 0xffffffff -> do throwGetLastError "service_loop"
241 r2 <- c_readIOManagerEvent
244 _ | r2 == io_MANAGER_WAKEUP -> return False
245 _ | r2 == io_MANAGER_DIE -> return True
246 0 -> return False -- spurious wakeup
247 _ -> do start_console_handler (r2 `shiftR` 1); return False
248 unless exit $ service_cont wakeup delays'
250 _other -> service_cont wakeup delays' -- probably timeout
252 service_cont :: HANDLE -> [DelayReq] -> IO ()
253 service_cont wakeup delays = do
254 r <- atomicModifyIORef prodding (\_ -> (False,False))
255 r `seq` return () -- avoid space leak
256 service_loop wakeup delays
258 -- must agree with rts/win32/ThrIOManager.c
259 io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word32
260 io_MANAGER_WAKEUP = 0xffffffff
261 io_MANAGER_DIE = 0xfffffffe
267 -- these are sent to Services only.
270 deriving (Eq, Ord, Enum, Show, Read, Typeable)
272 start_console_handler :: Word32 -> IO ()
273 start_console_handler r =
274 case toWin32ConsoleEvent r of
275 Just x -> withMVar win32ConsoleHandler $ \handler -> do
276 _ <- forkIO (handler x)
280 toWin32ConsoleEvent :: Num a => a -> Maybe ConsoleEvent
281 toWin32ConsoleEvent ev =
283 0 {- CTRL_C_EVENT-} -> Just ControlC
284 1 {- CTRL_BREAK_EVENT-} -> Just Break
285 2 {- CTRL_CLOSE_EVENT-} -> Just Close
286 5 {- CTRL_LOGOFF_EVENT-} -> Just Logoff
287 6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown
290 win32ConsoleHandler :: MVar (ConsoleEvent -> IO ())
291 win32ConsoleHandler = unsafePerformIO (newMVar (error "win32ConsoleHandler"))
293 wakeupIOManager :: IO ()
294 wakeupIOManager = c_sendIOManagerEvent io_MANAGER_WAKEUP
296 -- Walk the queue of pending delays, waking up any that have passed
297 -- and return the smallest delay to wait for. The queue of pending
298 -- delays is kept ordered.
299 getDelay :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD)
300 getDelay _ [] = return ([], iNFINITE)
301 getDelay now all@(d : rest)
303 Delay time m | now >= time -> do
306 DelaySTM time t | now >= time -> do
307 atomically $ writeTVar t True
310 -- delay is in millisecs for WaitForSingleObject
311 let micro_seconds = delayTime d - now
312 milli_seconds = (micro_seconds + 999) `div` 1000
313 in return (all, fromIntegral milli_seconds)
315 foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c)
316 c_getIOManagerEvent :: IO HANDLE
318 foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c)
319 c_readIOManagerEvent :: IO Word32
321 foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c)
322 c_sendIOManagerEvent :: Word32 -> IO ()
324 foreign import stdcall "WaitForSingleObject"
325 c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD