GHC/Conc/Windows.hs

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