Erik de Castro Lopo pushed to branch wip/fix-9809 at Glasgow Haskell Compiler / GHC Commits: ac870ad5 by Simon Jakobi at 2026-10-28T04:40:42-04:00 X86 NCG: use 32-bit POPCNT for sub-word popcounts A 32-bit write zero-extends the result to the full register, so we don't need to emit additional code for this. We also skip emitting zero-extension instructions for the argument when it is already visibly zero-extended. For the byte-wise popcount loop from #24813, this shrinks the popcount sequence from 5 instructions to 3. Assisted-by: Claude Fable 5.1 - - - - - 53087373 by Facundo Domínguez at 2026-10-28T04:41:32-04:00 Use a ShortByteString in Serialized instead of [Word8] This makes the in-memory representation 40x more compact for all values stored in annotations. A test is added to measure the representation size of annotations specified in the compiler input. The GHC API is modified. All functions that previously handled annotations in [Word8] form now use ShortByteString. The following definitions have modified types: * GHC.findGlobalAnns * GHC.Tc.Gen.Splice.getAnnotationsByTypeRep * GHC.Core.Opt.Monad.getAnnotations * GHC.Core.Opt.Monad.getFirstAnnotations * GHC.Types.Annotations.deserializeAnns * GHC.Types.Annotations.findAnns * GHC.Types.Annotations.findAnnsByTypeRep * GHC.Serialized.Serialized * GHC.Serialized.toSerialized * GHC.Serialized.fromSerialized * GHC.Serialized.serializeWithData * GHC.Serialized.deserializeWithData * GHCi.Message.ReifyAnnotations Fixes #28002. - - - - - af899dcc by Erik de Castro Lopo at 2026-10-28T22:27:57+11:00 TimerManager: publish only evaluated timeout queues (#9809) When many threads register timeouts at once, for example 100k forked threads each calling registerDelay or threadDelay, the timer manager showed huge GC overhead, memory use and timer latency. With 100k forked registrations on -N4, master took 0.59 s and 437 MB peak memory, against 0.03 s and 31 MB when the same registrations come from one thread. The cause goes back to 2d5eccdf1c ("IO manager: Edit the timeout queue directly, rather than using an edit list", fixing #7653), which made every registration atomicModifyIORef' the shared timeout queue. That publishes the new queue as a thunk and only evaluates it afterwards, so each thread builds its O(log n) insert on top of the previous thread's unevaluated insert, giving thunk chains, threads blocking on each other's partly evaluated updates, and many queue copies kept alive at once. Registering threads now use a compare-and-swap loop that evaluates the new queue before publishing it (IntPSQ is spine strict, so WHNF is fully evaluated). The timer manager's own update in mkTimeout keeps using atomicModifyIORef': with compare-and-swap its long update almost never won against a stream of short inserts on other capabilities, which starved it and delayed expired timeouts by hundreds of milliseconds. Forked registrations of 100k timeouts (median of 5 runs): -N4: 0.589 s, 437 MB -> 0.077 s, 37 MB -N12: 1.182 s, 465 MB -> 0.125 s, 74 MB Forked registrations of 1M timeouts on -N1: 5.85 s (range 0.69-6.49 s), 1824 MB -> 0.69 s, 193 MB Single-thread registrations are unchanged or slightly faster, and timer latency during registration storms improves (p99 lateness of a 1 ms threadDelay during 100k forked registrations on -N4: 342-534 ms -> 4-7 ms). The registration code still runs in constant stack, so #7653 stays fixed; T7653 and the concurrent, base and ghc-internal testsuites pass. modifyTimeouts is OPAQUE so that the optimiser cannot expose the edit function's inspection of the old queue next to the compare-and-swap and replace the expected pointer with the evaluated queue, which would make the compare-and-swap fail forever when the MutVar# holds a thunk or indirection. See Note [Pointer equality in modifyTimeouts]. Regression tests included. Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com> - - - - - bf2d932e by Moritz Angermann at 2026-10-28T22:27:57+11:00 testsuite: give pause_resume_via_safe_ffi_concurrent 60s on Darwin CI The 10s System.Timeout watchdog was a false deadlock: five serialized 1s pauses plus rts_pause waiting on threadDelay/timer-manager traffic overruns that budget on loaded Mac runners. Keep a watchdog so a real hang still fails. - - - - - 29 changed files: - + changelog.d/T28002 - + changelog.d/T28002-api - + changelog.d/T9809-timer-manager-contention - + changelog.d/ncg-x86-subword-popcnt - compiler/GHC.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Types/Annotations.hs - compiler/GHC/Utils/Outputable.hs - libraries/base/tests/.gitignore - + libraries/base/tests/T9809.hs - libraries/base/tests/all.T - libraries/ghc-boot/GHC/Serialized.hs - libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/TH.hs - libraries/ghci/GHCi/TH/Binary.hs - testsuite/tests/annotations/should_run/Makefile - + testsuite/tests/annotations/should_run/T16841.hs - + testsuite/tests/annotations/should_run/T16841.stdout - testsuite/tests/annotations/should_run/all.T - + testsuite/tests/codeGen/should_gen_asm/T24813.asm - + testsuite/tests/codeGen/should_gen_asm/T24813.cmm - testsuite/tests/codeGen/should_gen_asm/all.T - testsuite/tests/plugins/T26761Plugin.hs - testsuite/tests/plugins/all.T - testsuite/tests/rts/pause-resume/all.T - testsuite/tests/rts/pause-resume/pause_resume_via_safe_ffi_concurrent.hs Changes: ===================================== changelog.d/T28002 ===================================== @@ -0,0 +1,8 @@ +section: compiler +issues: #28002 +mrs: !16841 +synopsis: + Use ``ShortByteString`` in the ``Serialized`` type instead of ``[Word8]`` +description: + ``GHC.Serialized.Serialized`` now uses ``ByteString`` to store serialized data. + This makes in-memory representation more compact. ===================================== changelog.d/T28002-api ===================================== @@ -0,0 +1,21 @@ +section: ghc-lib +issues: #28002 +mrs: !16841 +synopsis: + Use ``ShortByteString`` in the ``Serialized`` type instead of ``[Word8]`` +description: + Breaking change: All functions that previously handled annotations in ``[Word8]`` + form now use ``ShortByteString``. The following definitions have modified types: + * ``GHC.findGlobalAnns`` + * ``GHC.Tc.Gen.Splice.getAnnotationsByTypeRep`` + * ``GHC.Core.Opt.Monad.getAnnotations`` + * ``GHC.Core.Opt.Monad.getFirstAnnotations`` + * ``GHC.Types.Annotations.deserializeAnns`` + * ``GHC.Types.Annotations.findAnns`` + * ``GHC.Types.Annotations.findAnnsByTypeRep`` + * ``GHC.Serialized.Serialized`` + * ``GHC.Serialized.toSerialized`` + * ``GHC.Serialized.fromSerialized`` + * ``GHC.Serialized.serializeWithData`` + * ``GHC.Serialized.deserializeWithData`` + * ``GHCi.Message.ReifyAnnotations`` ===================================== changelog.d/T9809-timer-manager-contention ===================================== @@ -0,0 +1,12 @@ +section: ghc-internal +synopsis: Fix excessive GC, memory use and timer latency when many threads + register timeouts at once with ``threadDelay``, ``registerDelay`` or + ``System.Timeout.timeout``. +issues: #9809 +mrs: !16863 +description: { + Threads registering timeouts now publish only fully evaluated updates to + the timer manager's timeout queue, using a compare-and-swap loop, instead + of building chains of unevaluated updates that other threads then had to + evaluate or block on. +} ===================================== changelog.d/ncg-x86-subword-popcnt ===================================== @@ -0,0 +1,5 @@ +section: compiler +synopsis: The x86 native code generator now emits shorter code for 8-bit and + 16-bit ``popCount`` when :ghc-flag:`-msse4.2` is enabled. +mrs: !16640 +issues: #24813 ===================================== compiler/GHC.hs ===================================== @@ -453,12 +453,12 @@ import qualified GHC.Unit.Home.Graph as HUG import Control.Applicative ((<|>)) import Control.Monad import Control.Monad.Catch as MC +import Data.ByteString.Short (ShortByteString) import Data.Foldable import Data.Function ((&)) import Data.IORef import Data.List (isPrefixOf) import Data.Typeable ( Typeable ) -import Data.Word ( Word8 ) import qualified Data.Map.Strict as Map import Data.Set (Set) @@ -1526,7 +1526,7 @@ lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing) lookupGlobalName name = withSession $ \hsc_env -> do liftIO $ lookupType hsc_env name -findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a] +findGlobalAnns :: (GhcMonad m, Typeable a) => (ShortByteString -> a) -> AnnTarget Name -> m [a] findGlobalAnns deserialize target = withSession $ \hsc_env -> do ann_env <- liftIO $ prepareAnnotations hsc_env Nothing return (findAnns deserialize ann_env target) ===================================== compiler/GHC/CmmToAsm/X86/CodeGen.hs ===================================== @@ -6739,20 +6739,23 @@ genPopCnt bid width dst src = do True -> do code_src <- getAnyReg src - src_r <- getNewRegNat format + -- Sub-word popcounts use 32-bit POPCNT, whose write zero-extends the + -- result to the full register. + src_r <- getNewRegNat (max II32 format) let dst_r = getRegisterReg platform (CmmLocal dst) + -- A sub-word argument is a full Word# whose upper bits may be + -- dirty, so zero-extend it unless it visibly already is. + zx_src + | CmmMachOp (MO_UU_Conv from _) [_] <- src, from <= width + = nilOL + | otherwise + = unitOL (MOVZxL format (OpReg src_r) (OpReg src_r)) return $ code_src src_r `appOL` - (if width == W8 then - -- The POPCNT instruction doesn't take a r/m8 - unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL` - unitOL (POPCNT II16 (OpReg src_r) dst_r) - else - unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL` (if width == W8 || width == W16 then - -- We used a 16-bit destination register above, - -- so zero-extend - unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r)) - else nilOL) + zx_src `appOL` + unitOL (POPCNT II32 (OpReg src_r) dst_r) + else + unitOL (POPCNT format (OpReg src_r) dst_r)) False -> -- generate C call to hs_popcntN in ghc-prim ===================================== compiler/GHC/Core/Opt/Monad.hs ===================================== @@ -68,9 +68,9 @@ import GHC.Unit.Module.ModGuts import GHC.Unit.External import Data.Bifunctor ( bimap ) +import Data.ByteString.Short ( ShortByteString ) import Data.Dynamic import Data.Maybe (listToMaybe) -import Data.Word import Control.Monad import Control.Applicative ( Alternative(..) ) @@ -323,14 +323,14 @@ get_eps = do -- annotations. -- -- See Note [Annotations] -getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a]) +getAnnotations :: Typeable a => (ShortByteString -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a]) getAnnotations deserialize guts = do hsc_env <- getHscEnv ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts) return (deserializeAnns deserialize ann_env) -- | Get at most one annotation of a given type per annotatable item. -getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a) +getFirstAnnotations :: Typeable a => (ShortByteString -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a) getFirstAnnotations deserialize guts = bimap mod name <$> getAnnotations deserialize guts where ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -155,10 +155,10 @@ import Control.DeepSeq import Control.Monad import Data.Binary import Data.Binary.Get +import Data.ByteString.Short (ShortByteString) import Data.Containers.ListUtils ( nubOrd ) import Data.List ( sortBy ) import Data.Maybe -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB import Data.Dynamic ( fromDynamic, toDyn ) import qualified Data.IntMap as IntMap @@ -1947,7 +1947,7 @@ handleTHMessage msg = case msg of ReifyInstances n ts -> wrapTHResult $ runQinTcM $ TH.reifyInstances n ts ReifyRoles n -> wrapTHResult $ runQinTcM $ TH.reifyRoles n ReifyAnnotations lookup tyrep -> - wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep) + wrapTHResult $ getAnnotationsByTypeRep lookup tyrep ReifyModule m -> wrapTHResult $ runQinTcM $ TH.reifyModule m ReifyConStrictness nm -> wrapTHResult $ runQinTcM $ TH.reifyConStrictness nm GetPackageRoot -> wrapTHResult $ runQinTcM $ TH.getPackageRoot @@ -1967,7 +1967,7 @@ handleTHMessage msg = case msg of FailIfErrs -> wrapTHResult failIfErrsM _ -> panic ("handleTHMessage: unexpected message " ++ show msg) -getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]] +getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [ShortByteString] getAnnotationsByTypeRep th_name tyrep = do { name <- lookupThAnnLookup th_name ; topEnv <- getTopEnv ===================================== compiler/GHC/Types/Annotations.hs ===================================== @@ -27,9 +27,9 @@ import GHC.Utils.Outputable import GHC.Serialized import Control.Monad +import Data.ByteString.Short ( ShortByteString ) import Data.Maybe import Data.Typeable -import Data.Word ( Word8 ) import Control.DeepSeq -- | Represents an annotation after it has been sufficiently desugared from @@ -112,14 +112,14 @@ plusAnnEnv a b = -- | Find the annotations attached to the given target as 'Typeable' -- values of your choice. If no deserializer is specified, -- only transient annotations will be returned. -findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a] +findAnns :: Typeable a => (ShortByteString -> a) -> AnnEnv -> CoreAnnTarget -> [a] findAnns deserialize env = mapMaybe (fromSerialized deserialize) . findAnnPayloads env -- | Find the annotations attached to the given target as 'Typeable' -- values of your choice. If no deserializer is specified, -- only transient annotations will be returned. -findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]] +findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [ShortByteString] findAnnsByTypeRep env target tyrep = [ ws | Serialized tyrep' ws <- findAnnPayloads env target , tyrep' == tyrep ] @@ -134,7 +134,7 @@ findAnnPayloads env target = -- | Deserialize all annotations of a given type. This happens lazily, that is -- no deserialization will take place until the [a] is actually demanded and -- the [a] can also be empty (the UniqFM is not filtered). -deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a]) +deserializeAnns :: Typeable a => (ShortByteString -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a]) deserializeAnns deserialize env = ( mapModuleEnv deserAnns (ann_mod_env env) , mapNameEnv deserAnns (ann_name_env env) ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -138,6 +138,7 @@ import GHC.Utils.Misc (lastMaybe, snocView) import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import qualified Data.ByteString.Short as Short import Data.Char import qualified Data.Map as M import Data.Int @@ -1105,7 +1106,7 @@ instance Outputable a => Outputable (SCC a) where ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) instance Outputable Serialized where - ppr (Serialized the_type bytes) = int (length bytes) <+> text "of type" <+> text (show the_type) + ppr (Serialized the_type bytes) = int (Short.length bytes) <+> text "of type" <+> text (show the_type) instance Outputable Extension where ppr = text . show ===================================== libraries/base/tests/.gitignore ===================================== @@ -275,4 +275,5 @@ /weak001 /T9395 /T9532 +/T9809 /T11555 ===================================== libraries/base/tests/T9809.hs ===================================== @@ -0,0 +1,29 @@ +-- #9809: when many threads registered timeouts at the same time, the +-- TimerManager published unevaluated timeout queues with atomicModifyIORef'. +-- The threads then built long chains of thunks and blocked on each other's +-- black holes, and the heap grew to hundreds of megabytes. all.T runs this +-- test with a heap limit that the old code exceeded. + +import Control.Concurrent +import Control.Monad +import Data.IORef +import GHC.Conc (TVar, atomically, newTVarIO, readTVar, registerDelay, retry, writeTVar) + +main :: IO () +main = do + let n = 100000 + ref <- newIORef [] + registered <- newTVarIO (0 :: Int) + replicateM_ n . forkIO $ do + tv <- registerDelay 10 + atomicModifyIORef' ref (\tvs -> (tv : tvs, ())) + atomically $ readTVar registered >>= writeTVar registered . (+ 1) + atomically $ do + r <- readTVar registered + when (r /= n) retry + readIORef ref >>= mapM_ waitFor + +-- | Block until a delay has fired, so that the test also checks that the +-- TimerManager fires every timeout. +waitFor :: TVar Bool -> IO () +waitFor tv = atomically $ readTVar tv >>= \fired -> unless fired retry ===================================== libraries/base/tests/all.T ===================================== @@ -193,6 +193,12 @@ test('T7653', [when(opsys('mingw32'), skip), omit_ways(prof_ways + ghci_ways)], compile_and_run, ['']) test('T7787', normal, compile_and_run, ['']) +# Before the fix for #9809 this needed more than 256MB of heap. +test('T9809', [req_ghc_smp, + req_target_smp, + only_ways(['threaded1', 'threaded2', 'nonmoving_thr'])], + compile_and_run, ['-threaded -with-rtsopts="-N2 -M128m"']) + test('topHandler01', [when(opsys('mingw32'), skip), js_broken(22261), req_process], compile_and_run, ['']) test('topHandler02', [when(opsys('mingw32'), skip), ===================================== libraries/ghc-boot/GHC/Serialized.hs ===================================== @@ -19,144 +19,68 @@ module GHC.Serialized ( ) where import Prelude -- See note [Why do we import Prelude here?] -import Data.Bits -import Data.Word ( Word8 ) -import Data.Data import Control.DeepSeq +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as Short +import qualified Data.ByteString.Lazy as ByteString.Lazy +import Data.Data -- | Represents a serialized value of a particular type. Attempts can be made to deserialize it at certain types -data Serialized = Serialized TypeRep [Word8] +data Serialized = Serialized TypeRep ShortByteString instance NFData Serialized where rnf (Serialized tr ws) = rnf tr `seq` rnf ws -- | Put a Typeable value that we are able to actually turn into bytes into a 'Serialized' value ready for deserialization later -toSerialized :: forall a. Typeable a => (a -> [Word8]) -> a -> Serialized +toSerialized :: forall a. Typeable a => (a -> ShortByteString) -> a -> Serialized toSerialized serialize what = Serialized (typeOf what) (serialize what) -- | If the 'Serialized' value contains something of the given type, then use the specified deserializer to return @Just@ that. -- Otherwise return @Nothing@. -fromSerialized :: forall a. Typeable a => ([Word8] -> a) -> Serialized -> Maybe a +fromSerialized :: forall a. Typeable a => (ShortByteString -> a) -> Serialized -> Maybe a fromSerialized deserialize (Serialized the_type bytes) | the_type == rep = Just (deserialize bytes) | otherwise = Nothing where rep = typeRep (Proxy :: Proxy a) -- | Use a 'Data' instance to implement a serialization scheme dual to that of 'deserializeWithData' -serializeWithData :: Data a => a -> [Word8] -serializeWithData what = serializeWithData' what [] - -serializeWithData' :: Data a => a -> [Word8] -> [Word8] -serializeWithData' what = fst $ gfoldl (\(before, a_to_b) a -> (before . serializeWithData' a, a_to_b a)) - (\x -> (serializeConstr (constrRep (toConstr what)), x)) - what +serializeWithData :: Data a => a -> ShortByteString +serializeWithData = Short.toShort . ByteString.Lazy.toStrict . runPut . putData -- | Use a 'Data' instance to implement a deserialization scheme dual to that of 'serializeWithData' -deserializeWithData :: Data a => [Word8] -> a -deserializeWithData = snd . deserializeWithData' - -deserializeWithData' :: forall a. Data a => [Word8] -> ([Word8], a) -deserializeWithData' bytes = deserializeConstr bytes $ \constr_rep bytes -> - gunfold (\(bytes, b_to_r) -> let (bytes', b) = deserializeWithData' bytes in (bytes', b_to_r b)) - (\x -> (bytes, x)) - (repConstr (dataTypeOf (undefined :: a)) constr_rep) - - -serializeConstr :: ConstrRep -> [Word8] -> [Word8] -serializeConstr (AlgConstr ix) = serializeWord8 1 . serializeInt ix -serializeConstr (IntConstr i) = serializeWord8 2 . serializeInteger i -serializeConstr (FloatConstr r) = serializeWord8 3 . serializeRational r -serializeConstr (CharConstr c) = serializeWord8 4 . serializeChar c - - -deserializeConstr :: [Word8] -> (ConstrRep -> [Word8] -> a) -> a -deserializeConstr bytes k = deserializeWord8 bytes $ \constr_ix bytes -> - case constr_ix of - 1 -> deserializeInt bytes $ \ix -> k (AlgConstr ix) - 2 -> deserializeInteger bytes $ \i -> k (IntConstr i) - 3 -> deserializeRational bytes $ \r -> k (FloatConstr r) - 4 -> deserializeChar bytes $ \c -> k (CharConstr c) - x -> error $ "deserializeConstr: unrecognised serialized constructor type " ++ show x ++ " in context " ++ show bytes - - -serializeFixedWidthNum :: forall a. (Integral a, FiniteBits a) => a -> [Word8] -> [Word8] -serializeFixedWidthNum what = go (finiteBitSize what) what - where - go :: Int -> a -> [Word8] -> [Word8] - go size current rest - | size <= 0 = rest - | otherwise = fromIntegral (current .&. 255) : go (size - 8) (current `shiftR` 8) rest - -deserializeFixedWidthNum :: forall a b. (Integral a, FiniteBits a) => [Word8] -> (a -> [Word8] -> b) -> b -deserializeFixedWidthNum bytes k = go (finiteBitSize (undefined :: a)) bytes k - where - go :: Int -> [Word8] -> (a -> [Word8] -> b) -> b - go size bytes k - | size <= 0 = k 0 bytes - | otherwise = case bytes of - (byte:bytes) -> go (size - 8) bytes (\x -> k ((x `shiftL` 8) .|. fromIntegral byte)) - [] -> error "deserializeFixedWidthNum: unexpected end of stream" - - -serializeEnum :: (Enum a) => a -> [Word8] -> [Word8] -serializeEnum = serializeInt . fromEnum - -deserializeEnum :: Enum a => [Word8] -> (a -> [Word8] -> b) -> b -deserializeEnum bytes k = deserializeInt bytes (k . toEnum) - - -serializeWord8 :: Word8 -> [Word8] -> [Word8] -serializeWord8 x = (x:) - -deserializeWord8 :: [Word8] -> (Word8 -> [Word8] -> a) -> a -deserializeWord8 (byte:bytes) k = k byte bytes -deserializeWord8 [] _ = error "deserializeWord8: unexpected end of stream" - - -serializeInt :: Int -> [Word8] -> [Word8] -serializeInt = serializeFixedWidthNum - -deserializeInt :: [Word8] -> (Int -> [Word8] -> a) -> a -deserializeInt = deserializeFixedWidthNum - - -serializeRational :: (Real a) => a -> [Word8] -> [Word8] -serializeRational = serializeString . show . toRational - -deserializeRational :: (Fractional a) => [Word8] -> (a -> [Word8] -> b) -> b -deserializeRational bytes k = deserializeString bytes (k . fromRational . read) - - -serializeInteger :: Integer -> [Word8] -> [Word8] -serializeInteger = serializeString . show - -deserializeInteger :: [Word8] -> (Integer -> [Word8] -> a) -> a -deserializeInteger bytes k = deserializeString bytes (k . read) - - -serializeChar :: Char -> [Word8] -> [Word8] -serializeChar = serializeString . show - -deserializeChar :: [Word8] -> (Char -> [Word8] -> a) -> a -deserializeChar bytes k = deserializeString bytes (k . read) - - -serializeString :: String -> [Word8] -> [Word8] -serializeString = serializeList serializeEnum - -deserializeString :: [Word8] -> (String -> [Word8] -> a) -> a -deserializeString = deserializeList deserializeEnum - - -serializeList :: (a -> [Word8] -> [Word8]) -> [a] -> [Word8] -> [Word8] -serializeList serialize_element xs = serializeInt (length xs) . foldr (.) id (map serialize_element xs) - -deserializeList :: forall a b. (forall c. [Word8] -> (a -> [Word8] -> c) -> c) - -> [Word8] -> ([a] -> [Word8] -> b) -> b -deserializeList deserialize_element bytes k = deserializeInt bytes $ \len bytes -> go len bytes k - where - go :: Int -> [Word8] -> ([a] -> [Word8] -> b) -> b - go len bytes k - | len <= 0 = k [] bytes - | otherwise = deserialize_element bytes (\elt bytes -> go (len - 1) bytes (k . (elt:))) +deserializeWithData :: Data a => ShortByteString -> a +deserializeWithData bs = + case runGetOrFail getData (ByteString.Lazy.fromStrict (Short.fromShort bs)) of + Right (_, _, x) -> x + Left (_, off, msg) -> + error ("deserializeWithData: " ++ msg ++ " at offset " ++ show off) + +putData :: Data a => a -> Put +putData x = do + putConstrRep (constrRep (toConstr x)) + sequence_ (gmapQ putData x) + +getData :: forall a. Data a => Get a +getData = do + rep <- getConstrRep + fromConstrM getData (repConstr (dataTypeOf (undefined :: a)) rep) + +putConstrRep :: ConstrRep -> Put +putConstrRep (AlgConstr ix) = putWord8 1 >> put ix +putConstrRep (IntConstr i) = putWord8 2 >> put i +putConstrRep (FloatConstr r) = putWord8 3 >> put r +putConstrRep (CharConstr c) = putWord8 4 >> put c + +getConstrRep :: Get ConstrRep +getConstrRep = do + tag <- getWord8 + case tag of + 1 -> AlgConstr <$> get + 2 -> IntConstr <$> get + 3 -> FloatConstr <$> get + 4 -> CharConstr <$> get + _ -> fail ("unrecognised constructor tag " ++ show tag) ===================================== libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs ===================================== @@ -13,8 +13,10 @@ import GHC.Internal.Types () {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE UnboxedTuples #-} -- TODO: use the new Windows IO manager module GHC.Internal.Event.TimerManager @@ -53,6 +55,9 @@ import GHC.Internal.Control.Exception (finally) import GHC.Internal.Data.Foldable (sequence_) import GHC.Internal.Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef, writeIORef) +import GHC.Internal.IORef (IORef(..)) +import GHC.Internal.Prim (casMutVar#, readMutVar#) +import GHC.Internal.STRef (STRef(..)) import GHC.Internal.Err (errorWithoutStackTrace) import GHC.Internal.Clock (getMonotonicTimeNSec) import GHC.Internal.Conc.Signal (runHandlers) @@ -260,7 +265,7 @@ updateTimeout mgr (TK key) us = do editTimeouts :: TimerManager -> TimeoutEdit -> IO () editTimeouts mgr g = do - wake <- atomicModifyIORef' (emTimeouts mgr) f + wake <- modifyTimeouts (emTimeouts mgr) f when wake (wakeManager mgr) where f q = (q', wake) @@ -276,4 +281,75 @@ editTimeouts mgr g = do t0 /= t1 _ -> True +-- | Atomically replace the timeout queue with the first component of +-- @f old@ and return the second component. +-- +-- Unlike 'atomicModifyIORef'', the new queue is evaluated /before/ it is +-- published, using a compare-and-swap loop. 'atomicModifyIORef'' installs +-- the new contents as a thunk and only evaluates it afterwards, so when many +-- threads register timeouts at once (#9809) each one builds its insert on +-- top of the previous thread's unevaluated insert, giving long thunk chains, +-- threads blocking on each other's half evaluated updates and lots of extra +-- GC work. Since 'Q.IntPSQ' is spine strict, WHNF means fully evaluated, and +-- other threads only ever see a fully evaluated queue. +-- +-- The cost is that a thread whose compare-and-swap loses a race has to redo +-- its O(log n) update. The update runs in constant stack (see #7653). +-- +-- Only the short edits made by registering threads use this. The timer +-- manager's own update in 'mkTimeout' (removing every expired timeout) can +-- take much longer, and under a stream of registrations from other +-- capabilities its compare-and-swap would almost never succeed, starving it +-- so that expired timeouts don't fire. It therefore keeps using +-- 'atomicModifyIORef'', which never retries: it publishes a single thunk and +-- evaluates it straight away. A registering thread that reads that thunk +-- evaluates it (or waits for the manager to) before publishing its own fully +-- evaluated queue, so thunks still cannot pile up. +-- +-- 'casMutVar#' compares pointers, so the expected value must be exactly the +-- pointer read from the 'MutVar#'. See Note [Pointer equality in +-- modifyTimeouts] for why this function is OPAQUE. +{-# OPAQUE modifyTimeouts #-} +modifyTimeouts :: IORef TimeoutQueue -> (TimeoutQueue -> (TimeoutQueue, b)) -> IO b +modifyTimeouts (IORef (STRef ref)) f = IO modLoop + where + modLoop s0 = case readMutVar# ref s0 of + (# s1, oldVar #) -> case f oldVar of + (newVar, r) -> newVar `seq` case casMutVar# ref oldVar newVar s1 of + (# s2, 0#, _ #) -> (# s2, r #) + (# s2, _, _ #) -> modLoop s2 + +{- Note [Pointer equality in modifyTimeouts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'casMutVar#' succeeds only if the expected value is the very pointer stored +in the 'MutVar#', so all the difficulties of 'reallyUnsafePtrEquality#' +apply to it. In 'modifyTimeouts' the expected value is @oldVar@, exactly as +'readMutVar#' returned it, and that must survive optimisation. + +The danger is the optimiser seeing a @case@ on @oldVar@ in the same function +as the 'casMutVar#'. That would happen if 'modifyTimeouts' were inlined or +specialised at a call site, bringing in the body of @f@ (in 'editTimeouts', +@f@ inspects the queue to decide whether to wake the manager). The binder +swap (Note [Binder swap] in GHC.Core.Opt.OccurAnal) may then replace @oldVar@ +by the case binder, which is the /evaluated/ queue. That is a different +pointer whenever the 'MutVar#' holds a thunk or an indirection, for example +the selector thunk that 'atomicModifyIORef'' in 'mkTimeout' leaves behind. +Case-of-known-constructor can likewise replace it by a freshly built +constructor. Either way the compare-and-swap would keep failing and the +registering thread would spin. + +The OPAQUE pragma keeps @f@ an unknown function inside 'modifyTimeouts', so +there is never a @case@ on @oldVar@ to rewrite. OPAQUE rather than NOINLINE: +both stop inlining and specialisation, but NOINLINE still allows the +worker/wrapper transformation. Today that is harmless (the worker only +unboxes the 'IORef' and still takes @f@ as an argument), but OPAQUE states +the requirement directly: the body must be compiled as written and every call +must go to it. It also costs nothing, since 'editTimeouts' passes a closure +anyway. + +An alternative is to hide the expected pointer in a box built by a NOINLINE +function before @f@ runs (like the @Ticket@ type of the atomic-primops +package), but that allocates on every attempt. +-} + #endif ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -297,7 +297,7 @@ data THMessage a where ReifyInstances :: TH.Name -> [TH.Type] -> THMessage (THResult [TH.Dec]) ReifyRoles :: TH.Name -> THMessage (THResult [TH.Role]) ReifyAnnotations :: TH.AnnLookup -> TypeRep - -> THMessage (THResult [ByteString]) + -> THMessage (THResult [BS.ShortByteString]) ReifyModule :: TH.Module -> THMessage (THResult TH.ModuleInfo) ReifyConStrictness :: TH.Name -> THMessage (THResult [TH.DecidedStrictness]) ===================================== libraries/ghci/GHCi/TH.hs ===================================== @@ -100,7 +100,6 @@ import Control.Monad.IO.Class (MonadIO (..)) import Data.Binary import Data.Binary.Put import Data.ByteString (ByteString) -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB import Data.Data import Data.Dynamic @@ -169,7 +168,7 @@ instance MonadIO GHCiQ where -- serialize irrelevant annotations. reifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a] reifyAnnotations lookup = - map (deserializeWithData . B.unpack) <$> + map deserializeWithData <$> ghcCmd (ReifyAnnotations lookup typerep) where typerep = typeOf (undefined :: a) ===================================== libraries/ghci/GHCi/TH/Binary.hs ===================================== @@ -9,7 +9,6 @@ module GHCi.TH.Binary () where import Prelude -- See note [Why do we import Prelude here?] import Data.Binary -import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B import GHC.Serialized import qualified GHC.Boot.TH.Syntax as TH @@ -74,8 +73,8 @@ instance Binary TH.DocLoc -- We need Binary TypeRep for serializing annotations instance Binary Serialized where - put (Serialized tyrep wds) = put tyrep >> put (B.pack wds) - get = Serialized <$> get <*> (B.unpack <$> get) + put (Serialized tyrep wds) = put tyrep >> put wds + get = Serialized <$> get <*> get instance Binary TH.Bytes where put (TH.Bytes ptr off sz) = put bs ===================================== testsuite/tests/annotations/should_run/Makefile ===================================== @@ -9,3 +9,7 @@ config : echo "module Config where" >>$(CONFIG_HS) echo "cTop :: String" >> $(CONFIG_HS) echo 'cTop = "$(subst \,\\,$(shell '$(TEST_HC)' --print-libdir))"' >> $(CONFIG_HS) + +T16841: + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 -c T16841.hs + '$(TEST_HC)' $(TEST_HC_OPTS) --show-iface T16841.hi | grep 'annotated by' ===================================== testsuite/tests/annotations/should_run/T16841.hs ===================================== @@ -0,0 +1,15 @@ +-- | Measures the overhead of serializing annotations of a few types. +module T16841 where + +foo :: Int +foo = 42 + +{-# ANN foo (42 :: Int) #-} +{-# ANN foo (2^100 :: Integer) #-} +{-# ANN foo (3.25 :: Double) #-} +{-# ANN foo 'x' #-} +{-# ANN foo "helloworld" #-} +{-# ANN foo (Just True) #-} +{-# ANN foo ([1..100] :: [Int]) #-} +{-# ANN module (Left 7 :: Either Int String) #-} + ===================================== testsuite/tests/annotations/should_run/T16841.stdout ===================================== @@ -0,0 +1,9 @@ +Module target T16841 annotated by 15 of type Either Int [Char] +Named target foo annotated by 1509 of type [Int] +Named target foo annotated by 18 of type Maybe Bool +Named target foo annotated by 119 of type [Char] +Named target foo annotated by 2 of type Char +Named target foo annotated by 11 of type Double +Named target foo annotated by 24 of type Integer +Named target foo annotated by 6 of type Int + ===================================== testsuite/tests/annotations/should_run/all.T ===================================== @@ -16,6 +16,10 @@ test('annrun01', multimod_compile_and_run, ['annrun01', '-package ghc ' + config.ghc_th_way_flags]) +# Skipping on windows because of platform-specific failures. See +# https://gitlab.haskell.org/ghc/ghc/-/merge_requests/16841#note_706770 +test('T16841', [req_th, windows_skip, extra_files(['T16841.hs'])], makefile_test, ['T16841']) + """" Helpful things to C+P: ===================================== testsuite/tests/codeGen/should_gen_asm/T24813.asm ===================================== @@ -0,0 +1,10 @@ +popcnt8: + movzbl + popcnt + movq + jmp +popcnt16: + movzwl + popcnt + movq + jmp ===================================== testsuite/tests/codeGen/should_gen_asm/T24813.cmm ===================================== @@ -0,0 +1,16 @@ +#include "Cmm.h" + +// Popcount of a zero-extended sub-word value should be a single +// zero-extending load followed by one POPCNT (#24813). + +popcnt8 (W_ p) { + W_ r; + (r) = prim %popcnt8(%zx64(bits8[p])); + return (r); +} + +popcnt16 (W_ p) { + W_ r; + (r) = prim %popcnt16(%zx64(bits16[p])); + return (r); +} ===================================== testsuite/tests/codeGen/should_gen_asm/all.T ===================================== @@ -27,6 +27,7 @@ test('T25233', [unless(arch('x86_64'), skip), when(unregisterised(), skip)], compile_grep_asm, ['hs', True, '-O']) test('T25233b', [unless(arch('x86_64'), skip), when(unregisterised(), skip)], compile_grep_asm, ['cmm', True, '']) +test('T24813', is_amd64_codegen, compile_cmp_asm, ['cmm', '-msse4.2']) is_aarch64_codegen = [ unless(arch('aarch64'), skip), when(unregisterised(), skip), ===================================== testsuite/tests/plugins/T26761Plugin.hs ===================================== @@ -7,6 +7,7 @@ import GHC import GHC.Plugins import GHC.Tc.Types import GHC.Tc.Utils.Monad +import qualified Data.ByteString.Short as Short import qualified Data.Map as Map import Data.Word (Word8) import System.IO (hFlush, stdout) @@ -38,5 +39,5 @@ plugin = defaultPlugin { typeCheckResultAction = typecheckPlugin } -- check that it is visible from other modules. let ann = Annotation (ModuleTarget $ tcg_mod gblEnv) - (toSerialized id [0]) + (toSerialized id (Short.pack [0])) return gblEnv { tcg_anns = ann : tcg_anns gblEnv } ===================================== testsuite/tests/plugins/all.T ===================================== @@ -155,7 +155,7 @@ test('T14335', -fexternal-interpreter -package simple-plugin ' + config.plugin_way_flags]) test('T26761', [extra_files(['T26761Plugin.hs', 'T26761a.hs'])], - multimod_compile, ['T26761', '-package ghc ' + config.plugin_way_flags ]) + multimod_compile, ['T26761', '-package ghc -package bytestring ' + config.plugin_way_flags ]) test('plugin-recomp-pure', [extra_files(['plugin-recomp/', 'plugin-recomp-test.hs']), ===================================== testsuite/tests/rts/pause-resume/all.T ===================================== @@ -14,6 +14,8 @@ test('pause_resume_via_safe_ffi_concurrent', [ only_ways(['threaded1', 'threaded2']) , req_c , extra_files(['pause_resume.c','pause_resume.h']) + # Internal watchdog is 60s; give the harness room on loaded Darwin CI. + , run_timeout_multiplier(2) ], multi_compile_and_run, ['pause_resume_via_safe_ffi_concurrent', [('pause_resume.c','')], '']) test('pause_and_use_rts_api', ===================================== testsuite/tests/rts/pause-resume/pause_resume_via_safe_ffi_concurrent.hs ===================================== @@ -8,6 +8,7 @@ import Foreign.Marshal.Alloc import Foreign.Ptr import Foreign.Storable import System.Exit +import System.IO (hFlush, stdout) import System.Timeout foreign import ccall safe "pause_resume.h pauseAndResume" @@ -38,11 +39,17 @@ main = do countPtr putMVar mvar () - -- Wait (at least 2n seconds to be safe) for all threads to finish. - result <- timeout (2 * n * 1000000) (mapM_ takeMVar mvars) + -- Each pause holds the RTS for about a second, so n concurrent + -- calls serialize to ~n seconds. 2n (10s) was enough on Linux but + -- a false deadlock on Darwin CI: rts_pause waits for every + -- capability, and the counter threads keep hitting the timer + -- manager via threadDelay. Keep a watchdog so a real hang still + -- fails, but give 60s of slack. + result <- timeout (60 * 1000000) (mapM_ takeMVar mvars) case result of Nothing -> do putStrLn "Not all rts_pause/rts_resume threads have finished. Assuming deadlocked and failing test." + hFlush stdout exitFailure Just () -> do putStrLn "All threads finished" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cb573bc9cae5f7b2618ac8f0f310daa... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cb573bc9cae5f7b2618ac8f0f310daa... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help