Marge Bot pushed to branch wip/marge_bot_batch_merge_job 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. - - - - - 20c35f20 by David Eichmann at 2026-10-28T22:26:22-04:00 testsuite: Fix python type errors These errors appear when using the VSCode python extension which uses Pylance under the hood. - - - - - 78803540 by David Eichmann at 2026-10-28T22:26:22-04:00 Add test modifier to test over all IO Managers - - - - - e3a21c96 by Alan Zimmerman at 2026-10-28T22:26:22-04:00 EPA: Tidy up ExactPrint.markAnnListA' It takes an action which can modify the AnnList, but this is never used. So remove it. - - - - - 30 changed files: - + changelog.d/T28002 - + changelog.d/T28002-api - + 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/ghc-boot/GHC/Serialized.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/TH.hs - libraries/ghci/GHCi/TH/Binary.hs - rts/RtsUtils.c - testsuite/config/ghc - testsuite/driver/runtests.py - testsuite/driver/testglobals.py - testsuite/driver/testlib.py - testsuite/driver/testutil.py - 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/all.T - utils/check-exact/ExactPrint.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/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/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/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 ===================================== rts/RtsUtils.c ===================================== @@ -397,6 +397,7 @@ void printRtsInfo(const RtsConfig rts_config) { rts_config.rts_opts != NULL ? rts_config.rts_opts : ""); selectIOManager(); /* resolve the io-manager, accounting for flags */ mkRtsInfoPair("I/O manager default", showIOManager()); + mkRtsInfoPair("I/O managers", &IOMGRS_ENABLED_STR[1]); // skips the initial ' ' character in IOMGRS_ENABLED_STR printf(" ]\n"); } ===================================== testsuite/config/ghc ===================================== @@ -257,7 +257,9 @@ def get_compiler_info(): ) except Exception as err: - print("Exception thrown in testsuite/config/ghc.get_compiler_info: %s", err) + # We don't throw so that we can still discover tests before we've built + # GHC (i.e. config.compiler doesn't yet exist). + print("Exception thrown in testsuite/config/ghc.get_compiler_info: ", err) else: res = p.returncode == 0 @@ -315,6 +317,58 @@ def get_compiler_info(): config.ghc_th_way = "normal" config.ghc_th_hi_ext = "hi" + # I/O manager discovery. + # + # Which I/O managers (GHC's `--io-manager` RTS flag) a given RTS build + # supports depends on the target platform and on whether the RTS is the + # threaded or non-threaded flavour (see rts/IOManager.h's + # IOMGR_ENABLED_* macros). Rather than duplicate that platform/way + # dependent logic here, we ask the RTS itself using `+RTS --info -RTS` + # and extract the "I/O managers" value from stdout. + def discover_io_managers_generic(extra_flags): + import tempfile + + test_src = 'main :: IO ()\nmain = return ()\n' + + res = [None] + + with tempfile.TemporaryDirectory() as d: + src = Path(d) / 'IOMgrProbe.hs' + src.write_text(test_src) + exe = Path(d) / ('IoMgrProbe' + config.exeext) + + # -rtsopts is needed so that the resulting binary will even + # consider an --io-manager= flag (rather than immediately + # rejecting all "unsafe" RTS options). + cmd = '{} -v0 -rtsopts -o {} {} {}'.format( + config.compiler, + exe, + src, + ' '.join(extra_flags)) + try: + cp = subprocess.run( + cmd, + shell=True, + cwd=d, + stdout=subprocess.DEVNULL, + stderr=None if config.verbose >= 3 else subprocess.DEVNULL) + if cp.returncode != 0 or not exe.exists(): + raise Exception("Error in testsuite/config/ghc.discover_io_managers: failed to compile with: {}".format(cmd)) + res = list(discover_io_managers(exe, d)) + + except Exception as err: + # We don't throw so that we can still discover tests before we've built + # GHC (i.e. config.compiler doesn't yet exist). + print("Exception thrown in testsuite/config/ghc.discover_io_managers_generic: ", err) + + return res + + config.io_managers_nonthreaded = discover_io_managers_generic([]) + config.io_managers_threaded = ( + discover_io_managers_generic(['-threaded']) if config.ghc_with_threaded_rts + else []) + config.io_managers_all = list(set(config.io_managers_nonthreaded).union(set(config.io_managers_threaded))) + config.cmm_cpp_is_gcc = test_compile( ['-c'], test_filename='test.cmm', ===================================== testsuite/driver/runtests.py ===================================== @@ -28,7 +28,7 @@ import subprocess import asyncio -from testutil import getStdout, str_warn, str_info, print_table, shorten_metric_name, str_removeprefix +from testutil import discover_io_managers, getStdout, str_warn, str_info, print_table, shorten_metric_name, str_removeprefix from testglobals import getConfig, ghc_env, TestConfig, t, \ TestOptions, brokens, PerfMetric from my_typing import TestName ===================================== testsuite/driver/testglobals.py ===================================== @@ -126,6 +126,15 @@ class TestConfig: self.way_flags = {} # type: Dict[WayName, List[str]] self.way_rts_flags = {} # type: Dict[WayName, List[str]] + # I/O managers (GHC's `--io-manager` RTS flag) supported by the threaded runtime. + self.io_managers_threaded = [] # type: List[str] + + # I/O managers (GHC's `--io-manager` RTS flag) supported by the non-threaded runtime. + self.io_managers_nonthreaded = [] # type: List[str] + + # All I/O managers (GHC's `--io-manager` RTS flag) + self.io_managers_all = [] # type: List[str] + # Do we have a functional LLVM toolchain? self.have_llvm = False @@ -227,7 +236,7 @@ class TestConfig: self.allowed_perf_changes = {} # The test environment. - self.test_env = 'local' + self.test_env = TestEnv('local') # terminal supports colors self.supports_colors = False @@ -367,6 +376,14 @@ class TestOptions: # add these ways to the default set self.extra_ways = [] # type: List[WayName] + # IO Managers to test (passed as the --io-manager RTS option) + # * [None] - only default IO Manager + # * [...] - list of io managers e.g. "mio" or "poll" + self.io_managers = [None] # type: List[Optional[str]] + + # IO Manager used in the current test case. Set before each test case. None means default IO Manager + self.io_manager_current = None # type: Optional[str] + # the result we normally expect for this test self.expect = 'pass' ===================================== testsuite/driver/testlib.py ===================================== @@ -23,7 +23,7 @@ import subprocess from testglobals import config, ghc_env, default_testopts, brokens, t, \ TestRun, TestResult, TestOptions, PerfMetric -from testutil import strip_quotes, lndir, link_or_copy_file, passed, \ +from testutil import discover_io_managers, strip_quotes, lndir, link_or_copy_file, passed, \ failBecause, residency_testing_metrics, \ stable_perf_counters, \ PassFail, badResult, str_warn, str_removeprefix @@ -190,7 +190,7 @@ def no_lint( name, opts ): def stage1(name, opts): # See Note [Why is there no stage1 setup function?] - framework_fail(name, 'stage1 setup function does not exist', + framework_fail(name, None, 'add your test to testsuite/tests/stage1 instead') # Note [Why is there no stage1 setup function?] @@ -341,7 +341,7 @@ def req_th( name, opts ): req_interp(name, opts); if ghc_dynamic(): - return _omit_ways(name, opts, ['profasm', 'profthreaded']) + return _omit_ways(name, opts, [WayName('profasm'), WayName('profthreaded')]) def req_plugins( name, opts ): """ @@ -355,7 +355,7 @@ def req_plugins( name, opts ): req_interp(name, opts) # Plugins aren't supported with the external interpreter (#14335) - expect_broken_for(14335,['ext-interp'])(name,opts) + expect_broken_for(IssueNumber(14335),[WayName('ext-interp')])(name,opts) if config.cross: opts.skip = True @@ -569,6 +569,34 @@ def extra_ways( ways: List[WayName] ): return helper +# ----- + +def _io_managers( name: TestName, opts, io_mgrs: List[str] ) -> None: + opts.io_managers = io_mgrs + +def io_managers( io_mgrs: List[str] ): + """ + Further split test cases into the given IO Managers if available. + Available IO Managers are determined by the test case's way (threaded/non-threads) and OS. + You'll likely want to use `extra_ways(['threaded2'])` if you want to test threaded IO Managers (e.g. mio). + """ + return lambda name, opts: _io_managers(name, opts, io_mgrs) + +def all_available_io_managers( name: TestName, opts ): + """ + Further split test cases into all available IO Managers. + Available IO Managers are determined by the test case's way (threaded/non-threads) and OS. + You'll likely want to use `extra_ways(['threaded2'])` to ensure threaded IO Managers are tested (e.g. mio). + """ + _io_managers(name, opts, config.io_managers_all) + +def all_available_io_managers_except(exclude: List[str]): + """ + Further split test cases into all available (except the given excluded) IO Managers. + Available IO Managers are determined by the test case's way (threaded/non-threads) and OS. + You'll likely want to use `extra_ways(['threaded2'])` to ensure threaded IO Managers are tested (e.g. mio). + """ + return lambda name, opts: _io_managers(name, opts, list(set(config.io_managers_all) - set(exclude))) # ----- @@ -661,18 +689,15 @@ def collect_size ( deviation, path ): def collect_size_func ( deviation, path_func ): return collect_generic_stat ( 'size', deviation, lambda way: os.path.getsize(in_testdir(path_func())) ) -def get_dir_size(path): +def get_dir_size(path) -> int: total = 0 - try: - with os.scandir(path) as it: - for entry in it: - if entry.is_file(): - total += entry.stat().st_size - elif entry.is_dir(): - total += get_dir_size(entry.path) - return total - except FileNotFoundError: - print("Exception: Could not find: " + path) + with os.scandir(path) as it: + for entry in it: + if entry.is_file(): + total += entry.stat().st_size + elif entry.is_dir(): + total += get_dir_size(entry.path) + return total def collect_size_dir ( deviation, path ): return collect_size_dir_func ( deviation, lambda: path ) @@ -790,7 +815,7 @@ def find_non_inplace_so(lib): return _find_so(lib,path_from_ghcPkg(lib, "dynamic-library-dirs"),False) -def collect_generic_stat ( metric, deviation: Optional[int], get_stat: Callable[[WayName], str]): +def collect_generic_stat ( metric, deviation: Optional[int], get_stat: Callable[[WayName], Any]): """ Define a generic stat test, which computes the statistic by calling the function given as the third argument. @@ -1135,7 +1160,7 @@ def _collect_compiler_perf_counters(counters: Set[str], deviation: Optional[int] # Slightly hacky, we need the requested perf_counters in 'simple_run'. # Thus, we have to globally register these counters opts.compiler_perf_counters += list(counters) - _collect_stats(name, opts, counters, deviation, False, True, True) + _collect_stats(name, opts, counters, deviation, None, True, True) return f @@ -1334,21 +1359,22 @@ def check_errmsg(needle): # grep_errmsg(regex,[groups]) # If groups are given, return only the matched groups # that matches the regex. -def grep_errmsg_norm(needle:str, groups = None): - - def get_match(str:str): - m = re.search(needle,str) - if m: - return "".join([m.group(g) for g in groups if m.group(g) is not None]) - else: - return None +def grep_errmsg_norm(needle:str, groups_may = None): - def norm(str) -> str: - if groups == None: + def norm(string) -> str: + if groups_may == None: return "".join( filter(lambda l: re.search(needle,l), - str.splitlines(True))) + string.splitlines(True))) else: - matches = [get_match(x) for x in str.splitlines(True)] + groups = groups_may + def get_match(string: str): + m = re.search(needle, string) + if m: + return "".join([m.group(g) for g in groups if m.group(g) is not None]) + else: + return None + + matches = [get_match(x) for x in string.splitlines(True)] res = "\n".join([x for x in matches if x]) return res return norm @@ -1573,6 +1599,15 @@ do_not_copy = ('.hi', '.o', '.dyn_hi' , '.dyn_o', '.out' ,'.hi-boot', '.o-boot') # 12112 +def way_supports_io_manager(way: WayName, io_manager: Optional[str]) -> bool: + # All ways support a default IO Manager + if io_manager is None: + return True + + way_is_threaded = '-threaded' in config.way_flags[way] + available_io_managers = config.io_managers_threaded if way_is_threaded else config.io_managers_nonthreaded + return io_manager in available_io_managers + async def test_common_work(name: TestName, opts, func, args) -> None: try: @@ -1621,7 +1656,22 @@ async def test_common_work(name: TestName, opts, # A test itself can request extra ways by setting opts.extra_ways all_ways = list(OrderedDict.fromkeys(all_ways + [way for way in opts.extra_ways if way not in all_ways])) - t.total_test_cases += len(all_ways) + # We split each way over available io managers + if len(opts.io_managers) == 0: + framework_fail(name, None, 'opts.io_managers is empty') + all_ways_and_io_managers = dict( + ( + way, + [io_manager + for io_manager in opts.io_managers + if way_supports_io_manager(way, io_manager) + ] + ) + for way in all_ways + ) + + for io_managers in all_ways_and_io_managers.values(): + t.total_test_cases += len(io_managers) only_ways = getTestOpts().only_ways ok_way = lambda way: \ @@ -1704,19 +1754,23 @@ async def test_common_work(name: TestName, opts, # Run the required tests... for way in do_ways: - if stopping(): - break - start = time.monotonic() - try: - await do_test(name, way, func, args, files) - except KeyboardInterrupt: - stopNow() - except Exception as e: - traceback.print_exc() - framework_fail(name, way, traceback.format_exc(), - runtime=time.monotonic() - start) + for io_manager in all_ways_and_io_managers[way]: + if stopping(): + break + start = time.monotonic() + try: + getTestOpts().io_manager_current = io_manager + await do_test(name ,way ,func ,args ,files) + except KeyboardInterrupt: + stopNow() + except Exception as e: + traceback.print_exc() + framework_fail(name, way, traceback.format_exc(), + runtime=time.monotonic() - start) + + for skipped_way in set(all_ways) - set(do_ways): + t.n_tests_skipped += len(all_ways_and_io_managers[skipped_way]) - t.n_tests_skipped += len(set(all_ways) - set(do_ways)) if getTestOpts().expect == 'missing-lib': t.n_missing_libs += 1 if config.cleanup and do_ways: @@ -1743,6 +1797,8 @@ async def do_test(name: TestName, start = time.monotonic() full_name = name + '(' + way + ')' + if opts.io_manager_current is not None: + full_name += ' (IO Manager: {})'.format(opts.io_manager_current) test_n = len(allTestNames) progress_args = [ full_name, t.total_tests, test_n, [len(t.unexpected_passes), @@ -1925,7 +1981,7 @@ def framework_warn(name: TestName, way: WayName, reason: str) -> None: # run_command. async def run_command( name, way, cmd ): - return await simple_run( name, '', override_options(cmd), '' ) + return await simple_run( name, WayName(''), override_options(cmd), '' ) async def makefile_test( name, way, target=None ): if target is None: @@ -2011,7 +2067,7 @@ async def multi_compile_fail( name, way, top_mod, extra_mods, extra_hc_opts ): return await do_compile( name, way, True, top_mod, extra_mods, [], extra_hc_opts) async def make_depend( name, way, mods, extra_hc_opts ): - return await do_compile( name, way, False, ' '.join(mods), [], [], extra_hc_opts, mode = '-M') + return await do_compile( name, way, False, Path(' '.join(mods)), [], [], extra_hc_opts, mode = '-M') async def do_compile(name: TestName, way: WayName, @@ -2142,7 +2198,7 @@ async def compile_grep_core(name: TestName, async def compile_and_run__(name: TestName, way: WayName, - top_mod: Path, + top_mod: Optional[Path], extra_mods: List[str], extra_hc_opts: str, backpack: bool=False, @@ -2425,6 +2481,9 @@ async def simple_run(name: TestName, way: WayName, prog: str, extra_run_opts: st my_rts_flags = rts_flags(way) + if opts.io_manager_current is not None: + my_rts_flags += ' +RTS --io-manager={0} -RTS '.format(opts.io_manager_current) + # Collect runtime stats if necessary: # isStatsTest and not isCompilerStatsTest(): # assume we are running a ghc compiled program. Collect stats. @@ -2450,6 +2509,12 @@ async def simple_run(name: TestName, way: WayName, prog: str, extra_run_opts: st output_file = perfStatsFile(False, name) + # Check that IO Manager is available + if opts.io_manager_current is not None: + available_io_managers = discover_io_managers(prog, opts.testdir) + if opts.io_manager_current not in available_io_managers: + framework_fail(name, way, 'IO Manager {} unexpectedly unavailable (available IO Managers: {}). `-non-threaded`/`-threaded` is only supported through way RTS flags (not manually added via test modifiers/args) when testing over IO Managers.'.format(opts.io_manager_current, available_io_managers)) + # run the command exit_code = await runCmdPerf(opts.compiler_perf_counters, cmd, output_file, working_dir=opts.testdir, @@ -2511,7 +2576,7 @@ def rts_flags(way: WayName) -> str: async def interpreter_run(name: TestName, way: WayName, extra_hc_opts: str, - top_mod: Path + top_mod: Optional[Path] ) -> PassFail: opts = getTestOpts() @@ -2882,11 +2947,11 @@ async def compare_outputs( if config.accept_platform: if_verbose(1, 'Accepting new output for platform "' + config.platform + '".') - expected_path += '-' + config.platform + expected_path = Path(str(expected_path) + '-' + config.platform) elif config.accept_os: if_verbose(1, 'Accepting new output for os "' + config.os + '".') - expected_path += '-' + config.os + expected_path = Path(str(expected_path) + '-' + config.os) else: if_verbose(1, 'Accepting new output.') @@ -3516,7 +3581,7 @@ def find_expected_file(name: TestName, suff: str, way: WayName) -> Path: for f in files: if in_srcdir(f).exists(): - return f + return Path(f) return basename ===================================== testsuite/driver/testutil.py ===================================== @@ -1,4 +1,5 @@ import os +import re import subprocess import shutil import tempfile @@ -179,3 +180,19 @@ def shorten_metric_name(name: str) -> str: "binary_size/if_compression(3)": "size/3", } return dic.get(name, name) + +# I/O manager discovery for a haskell binary. Returns the set of IO Manager +# strings supported by the binary +def discover_io_managers(hs_exe: Union[str, Path], cwd: Union[str, Path]) -> Set[str]: + rp = subprocess.run( + [str(hs_exe), '+RTS', '--info', '-RTS'], + cwd=cwd, + stdout=subprocess.PIPE, + stderr=subprocess.DEVNULL) + stdout = rp.stdout.decode('utf-8', errors='replace') + + m = re.search(r'\("I/O managers", "(.*)"\)', stdout) + if not m: + raise Exception('Expected stdout output of form \'... ("I/O managers", "select selectbis poll") ...\' but got:\n{}'.format(stdout)) + + return set(m.group(1).split()) ===================================== 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/all.T ===================================== @@ -674,8 +674,9 @@ test('T23142', [unless(debug_rts(), skip), req_interp], makefile_test, ['T23142' test('T23400', [], compile_and_run, ['-with-rtsopts -A8k']) test('IOManager', [js_skip, when(arch('wasm32'), skip), when(opsys('mingw32'), skip), - pre_cmd('$MAKE -s --no-print-directory IOManager.hs')], - compile_and_run, ['']) + pre_cmd('$MAKE -s --no-print-directory IOManager.hs'), + extra_ways(['threaded2']), all_available_io_managers_except('winio')], + compile_and_run, ['']) test('T24142', [req_target_smp], compile_and_run, ['-threaded -with-rtsopts "-N2"']) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1486,9 +1486,7 @@ markAnnList ann action = do markAnnList' :: (Monad m, Monoid w) => AnnList -> EP w m a -> EP w m (AnnList, a) markAnnList' ann action = do - markAnnListA' ann $ \a -> do - r <- action - return (a,r) + markAnnListA' ann $ action markAnnListA :: (Monad m, Monoid w) => EpAnn AnnList @@ -1503,14 +1501,14 @@ markAnnListA an action = do markAnnListA' :: (Monad m, Monoid w) => AnnList - -> (AnnList -> EP w m (AnnList, a)) + -> EP w m a -> EP w m (AnnList, a) markAnnListA' an action = do an0 <- markLensBracketsO' an lal_brackets an1 <- markEpAnnAllLT' an0 lal_semis - (an2, r) <- action an1 - an3 <- markLensBracketsC' an2 lal_brackets - return (an3, r) + r <- action + an2 <- markLensBracketsC' an1 lal_brackets + return (an2, r) -- --------------------------------------------------------------------- @@ -2413,9 +2411,7 @@ instance ExactPrint (ClsInstDecl GhcPs) where , cid_modifiers = mods }) = do (mbWarn', i', w', mbOverlap', inst_ty', mods') <- top_matter - (ann_list', decls') <- markAnnListA' ann_list $ \a -> do - r <- setLayoutBoth $ mapM markAnnotated decls - return (a,r) + (ann_list', decls') <- markAnnListA' ann_list $ setLayoutBoth $ mapM markAnnotated decls return (ClsInstDecl { cid_ext = (mbWarn', AnnClsInstDecl i' w' ann_list') , cid_poly_ty = inst_ty' , cid_decls = decls' @@ -3336,9 +3332,7 @@ markMaybeDodgyStmts (an,l) stmts = c' <- markEpToken c return (Left (o',c'), r) Right an' -> do - (an'',r') <- markAnnListA' an' $ \a -> do - r <- markAnnotatedWithLayout stmts - return (a, r) + (an'',r') <- markAnnListA' an' $ markAnnotatedWithLayout stmts return (Right an'',r') return ((an0, l), stmts') else return ((an, l), stmts) @@ -3411,9 +3405,7 @@ instance (Typeable body, = MG (origin,an) (L (setAnchorEpa l anc ts cs) matches) exact (MG (origin,an) (L l matches)) = do - (an0,matches') <- markAnnListA' an $ \a -> do - m' <- markAnnotated matches - return (a,m') + (an0,matches') <- markAnnListA' an $ markAnnotated matches return (MG (origin, an0) (L l matches')) -- --------------------------------------------------------------------- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eac8649f07a945988f53425b131ddd4... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eac8649f07a945988f53425b131ddd4... 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