GHC/Conc/Windows.hs

   1 {-# OPTIONS_GHC -XNoImplicitPrelude #-}
   2 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
   3 {-# OPTIONS_HADDOCK not-home #-}
   4 -----------------------------------------------------------------------------
   5 -- |
   6 -- Module      :  GHC.Conc.Windows
   7 -- Copyright   :  (c) The University of Glasgow, 1994-2002
   8 -- License     :  see libraries/base/LICENSE
   9 --
  10 -- Maintainer  :  cvs-ghc@haskell.org
  11 -- Stability   :  internal
  12 -- Portability :  non-portable (GHC extensions)
  13 --
  14 -- Windows I/O manager
  15 --
  16 -----------------------------------------------------------------------------
  17
  18 -- #not-home
  19 module GHC.Conc.Windows
  20        ( ensureIOManagerIsRunning
  21
  22        -- * Waiting
  23        , threadDelay
  24        , registerDelay
  25
  26        -- * Miscellaneous
  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
  30
  31        , asyncReadBA   -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
  32        , asyncWriteBA  -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
  33
  34        , ConsoleEvent(..)
  35        , win32ConsoleHandler
  36        , toWin32ConsoleEvent
  37        ) where
  38
  39 import Control.Monad
  40 import Data.Bits (shiftR)
  41 import Data.Maybe (Maybe(..))
  42 import Data.Typeable
  43 import Foreign.C.Error (throwErrno)
  44 import GHC.Base
  45 import GHC.Conc.Sync
  46 import GHC.Enum (Enum)
  47 import GHC.IO (unsafePerformIO)
  48 import GHC.IORef
  49 import GHC.MVar
  50 import GHC.Num (Num(..))
  51 import GHC.Ptr
  52 import GHC.Read (Read)
  53 import GHC.Real (div, fromIntegral)
  54 import GHC.Show (Show)
  55 import GHC.Word (Word32, Word64)
  56
  57 -- ----------------------------------------------------------------------------
  58 -- Thread waiting
  59
  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.)
  63
  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#) #)
  68
  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#) #)
  73
  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# #)
  80
  81 -- to aid the use of these primops by the IO Handle implementation,
  82 -- provide the following convenience funs:
  83
  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)
  88
  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)
  92
  93 -- ----------------------------------------------------------------------------
  94 -- Threaded RTS implementation of threadDelay
  95
  96 -- | Suspends the current thread for a given number of microseconds
  97 -- (GHC only).
  98 --
  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.
 102 --
 103 threadDelay :: Int -> IO ()
 104 threadDelay time
 105   | threaded  = waitForDelayEvent time
 106   | otherwise = IO $ \s ->
 107         case time of { I# time# ->
 108         case delay# time# s of { s' -> (# s', () #)
 109         }}
 110
 111 -- | Set the value of returned TVar to True after a given number of
 112 -- microseconds. The caveats associated with threadDelay also apply.
 113 --
 114 registerDelay :: Int -> IO (TVar Bool)
 115 registerDelay usecs
 116   | threaded = waitForDelayEventSTM usecs
 117   | otherwise = error "registerDelay: requires -threaded"
 118
 119 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
 120
 121 waitForDelayEvent :: Int -> IO ()
 122 waitForDelayEvent usecs = do
 123   m <- newEmptyMVar
 124   target <- calculateTarget usecs
 125   atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ()))
 126   prodServiceThread
 127   takeMVar m
 128
 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, ()))
 135    prodServiceThread
 136    return t
 137
 138 calculateTarget :: Int -> IO USecs
 139 calculateTarget usecs = do
 140     now <- getUSecOfDay
 141     return $ now + (fromIntegral usecs)
 142
 143 data DelayReq
 144   = Delay    {-# UNPACK #-} !USecs {-# UNPACK #-} !(MVar ())
 145   | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool)
 146
 147 {-# NOINLINE pendingDelays #-}
 148 pendingDelays :: IORef [DelayReq]
 149 pendingDelays = unsafePerformIO $ do
 150    m <- newIORef []
 151    sharedCAF m getOrSetGHCConcWindowsPendingDelaysStore
 152
 153 foreign import ccall unsafe "getOrSetGHCConcWindowsPendingDelaysStore"
 154     getOrSetGHCConcWindowsPendingDelaysStore :: Ptr a -> IO (Ptr a)
 155
 156 {-# NOINLINE ioManagerThread #-}
 157 ioManagerThread :: MVar (Maybe ThreadId)
 158 ioManagerThread = unsafePerformIO $ do
 159    m <- newMVar Nothing
 160    sharedCAF m getOrSetGHCConcWindowsIOManagerThreadStore
 161
 162 foreign import ccall unsafe "getOrSetGHCConcWindowsIOManagerThreadStore"
 163     getOrSetGHCConcWindowsIOManagerThreadStore :: Ptr a -> IO (Ptr a)
 164
 165 ensureIOManagerIsRunning :: IO ()
 166 ensureIOManagerIsRunning
 167   | threaded  = startIOManagerThread
 168   | otherwise = return ()
 169
 170 startIOManagerThread :: IO ()
 171 startIOManagerThread = do
 172   modifyMVar_ ioManagerThread $ \old -> do
 173     let create = do t <- forkIO ioManager; return (Just t)
 174     case old of
 175       Nothing -> create
 176       Just t  -> do
 177         s <- threadStatus t
 178         case s of
 179           ThreadFinished -> create
 180           ThreadDied     -> create
 181           _other         -> return (Just t)
 182
 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
 188
 189 delayTime :: DelayReq -> USecs
 190 delayTime (Delay t _) = t
 191 delayTime (DelaySTM t _) = t
 192
 193 type USecs = Word64
 194
 195 foreign import ccall unsafe "getUSecOfDay"
 196   getUSecOfDay :: IO USecs
 197
 198 {-# NOINLINE prodding #-}
 199 prodding :: IORef Bool
 200 prodding = unsafePerformIO $ do
 201    r <- newIORef False
 202    sharedCAF r getOrSetGHCConcWindowsProddingStore
 203
 204 foreign import ccall unsafe "getOrSetGHCConcWindowsProddingStore"
 205     getOrSetGHCConcWindowsProddingStore :: Ptr a -> IO (Ptr a)
 206
 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
 214
 215 -- ----------------------------------------------------------------------------
 216 -- Windows IO manager thread
 217
 218 ioManager :: IO ()
 219 ioManager = do
 220   wakeup <- c_getIOManagerEvent
 221   service_loop wakeup []
 222
 223 service_loop :: HANDLE          -- read end of pipe
 224              -> [DelayReq]      -- current delay requests
 225              -> IO ()
 226
 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
 231
 232   now <- getUSecOfDay
 233   (delays', timeout) <- getDelay now delays
 234
 235   r <- c_WaitForSingleObject wakeup timeout
 236   case r of
 237     0xffffffff -> do c_maperrno; throwErrno "service_loop"
 238     0 -> do
 239         r2 <- c_readIOManagerEvent
 240         exit <-
 241               case r2 of
 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'
 247
 248     _other -> service_cont wakeup delays' -- probably timeout
 249
 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
 255
 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
 260
 261 data ConsoleEvent
 262  = ControlC
 263  | Break
 264  | Close
 265     -- these are sent to Services only.
 266  | Logoff
 267  | Shutdown
 268  deriving (Eq, Ord, Enum, Show, Read, Typeable)
 269
 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)
 275                     return ()
 276      Nothing -> return ()
 277
 278 toWin32ConsoleEvent :: Num a => a -> Maybe ConsoleEvent
 279 toWin32ConsoleEvent ev =
 280    case ev of
 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
 286        _ -> Nothing
 287
 288 win32ConsoleHandler :: MVar (ConsoleEvent -> IO ())
 289 win32ConsoleHandler = unsafePerformIO (newMVar (error "win32ConsoleHandler"))
 290
 291 wakeupIOManager :: IO ()
 292 wakeupIOManager = c_sendIOManagerEvent io_MANAGER_WAKEUP
 293
 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)
 300   = case d of
 301      Delay time m | now >= time -> do
 302         putMVar m ()
 303         getDelay now rest
 304      DelaySTM time t | now >= time -> do
 305         atomically $ writeTVar t True
 306         getDelay now rest
 307      _otherwise ->
 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)
 312
 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...
 316 type HANDLE       = Ptr ()
 317 type DWORD        = Word32
 318
 319 iNFINITE :: DWORD
 320 iNFINITE = 0xFFFFFFFF -- urgh
 321
 322 foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c)
 323   c_getIOManagerEvent :: IO HANDLE
 324
 325 foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c)
 326   c_readIOManagerEvent :: IO Word32
 327
 328 foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c)
 329   c_sendIOManagerEvent :: Word32 -> IO ()
 330
 331 foreign import ccall unsafe "maperrno"             -- in Win32Utils.c
 332    c_maperrno :: IO ()
 333
 334 foreign import stdcall "WaitForSingleObject"
 335    c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD