GHC/Conc/Windows.hs

   1 {-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, ForeignFunctionInterface,
   2              DeriveDataTypeable #-}
   3 {-# OPTIONS_GHC -fno-warn-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
  21 module GHC.Conc.Windows
  22        ( ensureIOManagerIsRunning
  23
  24        -- * Waiting
  25        , threadDelay
  26        , registerDelay
  27
  28        -- * Miscellaneous
  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
  32
  33        , asyncReadBA   -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
  34        , asyncWriteBA  -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
  35
  36        , ConsoleEvent(..)
  37        , win32ConsoleHandler
  38        , toWin32ConsoleEvent
  39        ) where
  40
  41 import Control.Monad
  42 import Data.Bits (shiftR)
  43 import Data.Maybe (Maybe(..))
  44 import Data.Typeable
  45 import Foreign.C.Error (throwErrno)
  46 import GHC.Base
  47 import GHC.Conc.Sync
  48 import GHC.Enum (Enum)
  49 import GHC.IO (unsafePerformIO)
  50 import GHC.IORef
  51 import GHC.MVar
  52 import GHC.Num (Num(..))
  53 import GHC.Ptr
  54 import GHC.Read (Read)
  55 import GHC.Real (div, fromIntegral)
  56 import GHC.Show (Show)
  57 import GHC.Word (Word32, Word64)
  58
  59 -- ----------------------------------------------------------------------------
  60 -- Thread waiting
  61
  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.)
  65
  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#) #)
  70
  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#) #)
  75
  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# #)
  82
  83 -- to aid the use of these primops by the IO Handle implementation,
  84 -- provide the following convenience funs:
  85
  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)
  90
  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)
  94
  95 -- ----------------------------------------------------------------------------
  96 -- Threaded RTS implementation of threadDelay
  97
  98 -- | Suspends the current thread for a given number of microseconds
  99 -- (GHC only).
 100 --
 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.
 104 --
 105 threadDelay :: Int -> IO ()
 106 threadDelay time
 107   | threaded  = waitForDelayEvent time
 108   | otherwise = IO $ \s ->
 109         case time of { I# time# ->
 110         case delay# time# s of { s' -> (# s', () #)
 111         }}
 112
 113 -- | Set the value of returned TVar to True after a given number of
 114 -- microseconds. The caveats associated with threadDelay also apply.
 115 --
 116 registerDelay :: Int -> IO (TVar Bool)
 117 registerDelay usecs
 118   | threaded = waitForDelayEventSTM usecs
 119   | otherwise = error "registerDelay: requires -threaded"
 120
 121 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
 122
 123 waitForDelayEvent :: Int -> IO ()
 124 waitForDelayEvent usecs = do
 125   m <- newEmptyMVar
 126   target <- calculateTarget usecs
 127   atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ()))
 128   prodServiceThread
 129   takeMVar m
 130
 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, ()))
 137    prodServiceThread
 138    return t
 139
 140 calculateTarget :: Int -> IO USecs
 141 calculateTarget usecs = do
 142     now <- getUSecOfDay
 143     return $ now + (fromIntegral usecs)
 144
 145 data DelayReq
 146   = Delay    {-# UNPACK #-} !USecs {-# UNPACK #-} !(MVar ())
 147   | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool)
 148
 149 {-# NOINLINE pendingDelays #-}
 150 pendingDelays :: IORef [DelayReq]
 151 pendingDelays = unsafePerformIO $ do
 152    m <- newIORef []
 153    sharedCAF m getOrSetGHCConcWindowsPendingDelaysStore
 154
 155 foreign import ccall unsafe "getOrSetGHCConcWindowsPendingDelaysStore"
 156     getOrSetGHCConcWindowsPendingDelaysStore :: Ptr a -> IO (Ptr a)
 157
 158 {-# NOINLINE ioManagerThread #-}
 159 ioManagerThread :: MVar (Maybe ThreadId)
 160 ioManagerThread = unsafePerformIO $ do
 161    m <- newMVar Nothing
 162    sharedCAF m getOrSetGHCConcWindowsIOManagerThreadStore
 163
 164 foreign import ccall unsafe "getOrSetGHCConcWindowsIOManagerThreadStore"
 165     getOrSetGHCConcWindowsIOManagerThreadStore :: Ptr a -> IO (Ptr a)
 166
 167 ensureIOManagerIsRunning :: IO ()
 168 ensureIOManagerIsRunning
 169   | threaded  = startIOManagerThread
 170   | otherwise = return ()
 171
 172 startIOManagerThread :: IO ()
 173 startIOManagerThread = do
 174   modifyMVar_ ioManagerThread $ \old -> do
 175     let create = do t <- forkIO ioManager; return (Just t)
 176     case old of
 177       Nothing -> create
 178       Just t  -> do
 179         s <- threadStatus t
 180         case s of
 181           ThreadFinished -> create
 182           ThreadDied     -> create
 183           _other         -> return (Just t)
 184
 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
 190
 191 delayTime :: DelayReq -> USecs
 192 delayTime (Delay t _) = t
 193 delayTime (DelaySTM t _) = t
 194
 195 type USecs = Word64
 196
 197 foreign import ccall unsafe "getUSecOfDay"
 198   getUSecOfDay :: IO USecs
 199
 200 {-# NOINLINE prodding #-}
 201 prodding :: IORef Bool
 202 prodding = unsafePerformIO $ do
 203    r <- newIORef False
 204    sharedCAF r getOrSetGHCConcWindowsProddingStore
 205
 206 foreign import ccall unsafe "getOrSetGHCConcWindowsProddingStore"
 207     getOrSetGHCConcWindowsProddingStore :: Ptr a -> IO (Ptr a)
 208
 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
 216
 217 -- ----------------------------------------------------------------------------
 218 -- Windows IO manager thread
 219
 220 ioManager :: IO ()
 221 ioManager = do
 222   wakeup <- c_getIOManagerEvent
 223   service_loop wakeup []
 224
 225 service_loop :: HANDLE          -- read end of pipe
 226              -> [DelayReq]      -- current delay requests
 227              -> IO ()
 228
 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
 233
 234   now <- getUSecOfDay
 235   (delays', timeout) <- getDelay now delays
 236
 237   r <- c_WaitForSingleObject wakeup timeout
 238   case r of
 239     0xffffffff -> do c_maperrno; throwErrno "service_loop"
 240     0 -> do
 241         r2 <- c_readIOManagerEvent
 242         exit <-
 243               case r2 of
 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'
 249
 250     _other -> service_cont wakeup delays' -- probably timeout
 251
 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
 257
 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
 262
 263 data ConsoleEvent
 264  = ControlC
 265  | Break
 266  | Close
 267     -- these are sent to Services only.
 268  | Logoff
 269  | Shutdown
 270  deriving (Eq, Ord, Enum, Show, Read, Typeable)
 271
 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)
 277                     return ()
 278      Nothing -> return ()
 279
 280 toWin32ConsoleEvent :: Num a => a -> Maybe ConsoleEvent
 281 toWin32ConsoleEvent ev =
 282    case ev of
 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
 288        _ -> Nothing
 289
 290 win32ConsoleHandler :: MVar (ConsoleEvent -> IO ())
 291 win32ConsoleHandler = unsafePerformIO (newMVar (error "win32ConsoleHandler"))
 292
 293 wakeupIOManager :: IO ()
 294 wakeupIOManager = c_sendIOManagerEvent io_MANAGER_WAKEUP
 295
 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)
 302   = case d of
 303      Delay time m | now >= time -> do
 304         putMVar m ()
 305         getDelay now rest
 306      DelaySTM time t | now >= time -> do
 307         atomically $ writeTVar t True
 308         getDelay now rest
 309      _otherwise ->
 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)
 314
 315 -- ToDo: this just duplicates part of System.Win32.Types, which isn't
 316 -- available yet.  We should move some Win32 functionality down here,
 317 -- maybe as part of the grand reorganisation of the base package...
 318 type HANDLE       = Ptr ()
 319 type DWORD        = Word32
 320
 321 iNFINITE :: DWORD
 322 iNFINITE = 0xFFFFFFFF -- urgh
 323
 324 foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c)
 325   c_getIOManagerEvent :: IO HANDLE
 326
 327 foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c)
 328   c_readIOManagerEvent :: IO Word32
 329
 330 foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c)
 331   c_sendIOManagerEvent :: Word32 -> IO ()
 332
 333 foreign import ccall unsafe "maperrno"             -- in Win32Utils.c
 334    c_maperrno :: IO ()
 335
 336 foreign import stdcall "WaitForSingleObject"
 337    c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD