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