diff --git a/GHC/Event/Thread.hs b/GHC/Event/Thread.hs --- a/GHC/Event/Thread.hs +++ b/GHC/Event/Thread.hs @@ -18,7 +18,7 @@ -- TODO: Use new Windows I/O manager import Control.Exception (finally, SomeException, toException) import Data.Foldable (forM_, mapM_, sequence_) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicWriteIORef) import Data.Maybe (fromMaybe) import Data.Tuple (snd) import Foreign.C.Error (eBADF, errnoToIOError) @@ -29,7 +29,8 @@ import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO, labelThread, modifyMVar_, withMVar, newTVar, sharedCAF, getNumCapabilities, threadCapability, myThreadId, forkOn, - threadStatus, writeTVar, newTVarIO, readTVar, retry,throwSTM,STM) + threadStatus, writeTVar, newTVarIO, readTVar, retry, + throwSTM, STM, yield) import GHC.IO (mask_, uninterruptibleMask_, onException) import GHC.IO.Exception (ioError) import GHC.IOArray (IOArray, newIOArray, readIOArray, writeIOArray, @@ -41,6 +42,7 @@ new, registerFd, unregisterFd_) import qualified GHC.Event.Manager as M import qualified GHC.Event.TimerManager as TM +import GHC.Ix (inRange) import GHC.Num ((-), (+)) import GHC.Real (fromIntegral) import GHC.Show (showSignedInt) @@ -98,23 +100,45 @@ closeFdWith :: (Fd -> IO ()) -- ^ Action that performs the close. -> Fd -- ^ File descriptor to close. -> IO () -closeFdWith close fd = do - eventManagerArray <- readIORef eventManager - let (low, high) = boundsIOArray eventManagerArray - mgrs <- flip mapM [low..high] $ \i -> do - Just (_,!mgr) <- readIOArray eventManagerArray i - return mgr - -- 'takeMVar', and 'M.closeFd_' might block, although for a very short time. - -- To make 'closeFdWith' safe in presence of asynchronous exceptions we have - -- to use uninterruptible mask. - uninterruptibleMask_ $ do - tables <- flip mapM mgrs $ \mgr -> takeMVar $ M.callbackTableVar mgr fd - cbApps <- zipWithM (\mgr table -> M.closeFd_ mgr table fd) mgrs tables - close fd `finally` sequence_ (zipWith3 finish mgrs tables cbApps) +closeFdWith close fd = close_loop where finish mgr table cbApp = putMVar (M.callbackTableVar mgr fd) table >> cbApp zipWithM f xs ys = sequence (zipWith f xs ys) + -- The array inside 'eventManager' can be swapped out at any time, see + -- 'ioManagerCapabilitiesChanged'. See #21651. We detect this case by + -- checking the array bounds before and after. When such a swap has + -- happened we cleanup and try again + close_loop = do + eventManagerArray <- readIORef eventManager + let ema_bounds@(low, high) = boundsIOArray eventManagerArray + mgrs <- flip mapM [low..high] $ \i -> do + Just (_,!mgr) <- readIOArray eventManagerArray i + return mgr + -- 'takeMVar', and 'M.closeFd_' might block, although for a very short time. + -- To make 'closeFdWith' safe in presence of asynchronous exceptions we have + -- to use uninterruptible mask. + join $ uninterruptibleMask_ $ do + tables <- flip mapM mgrs $ \mgr -> takeMVar $ M.callbackTableVar mgr fd + new_ema_bounds <- boundsIOArray `fmap` readIORef eventManager + -- Here we exploit Note [The eventManager Array] + if new_ema_bounds /= ema_bounds + then do + -- the array has been modified. + -- mgrs still holds the right EventManagers, by the Note. + -- new_ema_bounds must be larger than ema_bounds, by the note. + -- return the MVars we took and try again + sequence_ $ zipWith (\mgr table -> finish mgr table (pure ())) mgrs tables + pure close_loop + else do + -- We surely have taken all the appropriate MVars. Even if the array + -- has been swapped, our mgrs is still correct. + -- Remove the Fd from all callback tables, close the Fd, and run all + -- callbacks. + cbApps <- zipWithM (\mgr table -> M.closeFd_ mgr table fd) mgrs tables + close fd `finally` sequence_ (zipWith3 finish mgrs tables cbApps) + pure (pure ()) + threadWait :: Event -> Fd -> IO () threadWait evt fd = mask_ $ do m <- newEmptyMVar @@ -177,10 +201,24 @@ getSystemEventManager :: IO (Maybe EventManager) getSystemEventManager = do t <- myThreadId - (cap, _) <- threadCapability t eventManagerArray <- readIORef eventManager - mmgr <- readIOArray eventManagerArray cap - return $ fmap snd mmgr + let r = boundsIOArray eventManagerArray + (cap, _) <- threadCapability t + -- It is possible that we've just increased the number of capabilities and the + -- new EventManager has not yet been constructed by + -- 'ioManagerCapabilitiesChanged'. We expect this to happen very rarely. + -- T21561 exercises this. + -- Two options to proceed: + -- 1) return the EventManager for capability 0. This is guaranteed to exist, + -- and "shouldn't" cause any correctness issues. + -- 2) Busy wait, with or without a call to 'yield'. This can't deadlock, + -- because we must be on a brand capability and there must be a call to + -- 'ioManagerCapabilitiesChanged' pending. + -- + -- We take the second option, with the yield, judging it the most robust. + if not (inRange r cap) + then yield >> getSystemEventManager + else fmap snd `fmap` readIOArray eventManagerArray cap getSystemEventManager_ :: IO EventManager getSystemEventManager_ = do @@ -191,6 +229,22 @@ foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore" getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a) +-- Note [The eventManager Array] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- A mutable array holding the current EventManager for each capability +-- An entry is Nothing only while the eventmanagers are initialised, see +-- 'startIOManagerThread' and 'ioManagerCapabilitiesChanged'. +-- The 'ThreadId' at array position 'cap' will have been 'forkOn'ed capabality +-- 'cap'. +-- The array will be swapped with newer arrays when the number of capabilities +-- changes(via 'setNumCapabilities'). However: +-- * the size of the arrays will never decrease; and +-- * The 'EventManager's in the array are not replaced with other +-- 'EventManager' constructors. +-- +-- This is a similar strategy as the rts uses for it's +-- capabilities array (n_capabilities is the size of the array, +-- enabled_capabilities' is the number of active capabilities). eventManager :: IORef (IOArray Int (Maybe (ThreadId, EventManager))) eventManager = unsafePerformIO $ do numCaps <- getNumCapabilities @@ -351,7 +405,9 @@ startIOManagerThread new_eventManagerArray -- update the event manager array reference: - writeIORef eventManager new_eventManagerArray + atomicWriteIORef eventManager new_eventManagerArray + -- We need an atomic write here because 'eventManager' is accessed + -- unsynchronized in 'getSystemEventManager' and 'closeFdWith' else when (new_n_caps > numEnabled) $ forM_ [numEnabled..new_n_caps-1] $ \i -> do Just (_,mgr) <- readIOArray eventManagerArray i diff --git a/GHC/IO/Windows/Handle.hsc b/GHC/IO/Windows/Handle.hsc --- a/GHC/IO/Windows/Handle.hsc +++ b/GHC/IO/Windows/Handle.hsc @@ -575,24 +575,23 @@ consoleRead :: Bool -> Io ConsoleHandle -> Ptr Word8 -> Word64 -> Int -> IO Int consoleRead blocking hwnd ptr _offset bytes - = withUTF16ToGhcInternal ptr bytes $ \reqBytes w_ptr -> - alloca $ \res -> do - cooked <- isCooked hwnd - -- Cooked input must be handled differently when the STD handles are - -- attached to a real console handle. For File based handles we can't do - -- proper cooked inputs, but since the actions are async you would get - -- results as soon as available. - -- - -- For console handles We have to use a lower level API then ReadConsole, - -- namely we must use ReadConsoleInput which requires us to process - -- all console message manually. - -- - -- Do note that MSYS2 shells such as bash don't attach to a real handle, - -- and instead have by default a pipe/file based std handles. Which - -- means the cooked behaviour is best when used in a native Windows - -- terminal such as cmd, powershell or ConEmu. - case cooked || not blocking of - False -> do + = alloca $ \res -> do + cooked <- isCooked hwnd + -- Cooked input must be handled differently when the STD handles are + -- attached to a real console handle. For File based handles we can't do + -- proper cooked inputs, but since the actions are async you would get + -- results as soon as available. + -- + -- For console handles We have to use a lower level API then ReadConsole, + -- namely we must use ReadConsoleInput which requires us to process + -- all console message manually. + -- + -- Do note that MSYS2 shells such as bash don't attach to a real handle, + -- and instead have by default a pipe/file based std handles. Which + -- means the cooked behaviour is best when used in a native Windows + -- terminal such as cmd, powershell or ConEmu. + case cooked || not blocking of + False -> withUTF16ToGhcInternal ptr bytes $ \reqBytes w_ptr -> do debugIO "consoleRead :: un-cooked I/O read." -- eotControl allows us to handle control characters like EOL -- without needing a newline, which would sort of defeat the point @@ -627,9 +626,9 @@ -- characters as they are. Technically this function can handle any -- console event. Including mouse, window and virtual key events -- but for now I'm only interested in key presses. - let entries = fromIntegral $ reqBytes `div` (#size INPUT_RECORD) + let entries = fromIntegral $ bytes `div` (#size INPUT_RECORD) allocaBytes entries $ \p_inputs -> - maybeReadEvent p_inputs entries res w_ptr + maybeReadEvent p_inputs entries res ptr -- Check to see if we have been explicitly asked to do a non-blocking -- I/O, and if we were, make sure that if we didn't have any console @@ -656,6 +655,7 @@ b_read <- fromIntegral <$> peek res read <- cobble b_read w_ptr p_inputs + debugIO $ "readEvent: =" ++ show read if read > 0 then return $ fromIntegral read else maybeReadEvent p_inputs entries res w_ptr @@ -664,7 +664,7 @@ -- minimum required to know which key/sequences were pressed. To do -- this and prevent having to fully port the PINPUT_RECORD structure -- in Haskell we use some GCC builtins to find the correct offsets. - cobble :: Int -> Ptr Word16 -> PINPUT_RECORD -> IO Int + cobble :: Int -> Ptr Word8 -> PINPUT_RECORD -> IO Int cobble 0 _ _ = do debugIO "cobble: done." return 0 cobble n w_ptr p_inputs = @@ -689,8 +689,18 @@ debugIO $ "cobble: offset - " ++ show char_offset debugIO $ "cobble: show > " ++ show char debugIO $ "cobble: repeat: " ++ show repeated + -- The documentation here is rather subtle, but + -- according to MSDN the uWChar being provided here + -- has been "translated". What this actually means + -- is that the surrogate pairs have already been + -- translated into byte sequences. That is, despite + -- the Word16 storage type, it's actually a byte + -- stream. This means we shouldn't try to decode + -- to UTF-8 again since we'd end up incorrectly + -- interpreting two bytes as an extended unicode + -- character. pokeArray w_ptr $ replicate repeated char - (+1) <$> cobble n' w_ptr' p_inputs' + (+repeated) <$> cobble n' w_ptr' p_inputs' else do debugIO $ "cobble: skip event." cobble n' w_ptr p_inputs' diff --git a/base.cabal b/base.cabal --- a/base.cabal +++ b/base.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: base -version: 4.16.3.0 +version: 4.16.4.0 -- NOTE: Don't forget to update ./changelog.md license: BSD-3-Clause diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,13 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) +## 4.16.4.0 *Nov 2022* + + * Shipped with GHC 9.2.5 + + * Fix races in IOManager (setNumCapabilities,closeFdWith) (#21651) + + * winio: do not re-translate input when handle is uncooked + ## 4.16.3.0 *May 2022* * Shipped with GHC 9.2.4