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