Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC

Commits:

30 changed files:

Changes:

  • changelog.d/T28002
    1 
    +section: compiler
    2 
    +issues: #28002
    3 
    +mrs: !16841
    4 
    +synopsis:
    5 
    +  Use ``ShortByteString`` in the ``Serialized`` type instead of ``[Word8]``
    6 
    +description:
    7 
    +  ``GHC.Serialized.Serialized`` now uses ``ByteString`` to store serialized data.
    8 
    +  This makes in-memory representation more compact.

  • changelog.d/T28002-api
    1 
    +section: ghc-lib
    2 
    +issues: #28002
    3 
    +mrs: !16841
    4 
    +synopsis:
    5 
    +  Use ``ShortByteString`` in the ``Serialized`` type instead of ``[Word8]``
    6 
    +description:
    7 
    +  Breaking change: All functions that previously handled annotations in ``[Word8]``
    8 
    +  form now use ``ShortByteString``. The following definitions have modified types:
    9 
    +  * ``GHC.findGlobalAnns``
    10 
    +  * ``GHC.Tc.Gen.Splice.getAnnotationsByTypeRep``
    11 
    +  * ``GHC.Core.Opt.Monad.getAnnotations``
    12 
    +  * ``GHC.Core.Opt.Monad.getFirstAnnotations``
    13 
    +  * ``GHC.Types.Annotations.deserializeAnns``
    14 
    +  * ``GHC.Types.Annotations.findAnns``
    15 
    +  * ``GHC.Types.Annotations.findAnnsByTypeRep``
    16 
    +  * ``GHC.Serialized.Serialized``
    17 
    +  * ``GHC.Serialized.toSerialized``
    18 
    +  * ``GHC.Serialized.fromSerialized``
    19 
    +  * ``GHC.Serialized.serializeWithData``
    20 
    +  * ``GHC.Serialized.deserializeWithData``
    21 
    +  * ``GHCi.Message.ReifyAnnotations``

  • changelog.d/ncg-x86-subword-popcnt
    1 
    +section: compiler
    2 
    +synopsis: The x86 native code generator now emits shorter code for 8-bit and
    3 
    +  16-bit ``popCount`` when :ghc-flag:`-msse4.2` is enabled.
    4 
    +mrs: !16640
    5 
    +issues: #24813

  • compiler/GHC.hs
    ... ... @@ -453,12 +453,12 @@ import qualified GHC.Unit.Home.Graph as HUG
    453 453 
     import Control.Applicative ((<|>))
    454 454 
     import Control.Monad
    455 455 
     import Control.Monad.Catch as MC
    456 
    +import Data.ByteString.Short (ShortByteString)
    456 457 
     import Data.Foldable
    457 458 
     import Data.Function ((&))
    458 459 
     import Data.IORef
    459 460 
     import Data.List (isPrefixOf)
    460 461 
     import Data.Typeable    ( Typeable )
    461 
    -import Data.Word        ( Word8 )
    462 462
    463 463 
     import qualified Data.Map.Strict as Map
    464 464 
     import Data.Set (Set)
    ... ... @@ -1526,7 +1526,7 @@ lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
    1526 1526 
     lookupGlobalName name = withSession $ \hsc_env -> do
    1527 1527 
        liftIO $ lookupType hsc_env name
    1528 1528
    1529 
    -findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
    1529 
    +findGlobalAnns :: (GhcMonad m, Typeable a) => (ShortByteString -> a) -> AnnTarget Name -> m [a]
    1530 1530 
     findGlobalAnns deserialize target = withSession $ \hsc_env -> do
    1531 1531 
         ann_env <- liftIO $ prepareAnnotations hsc_env Nothing
    1532 1532 
         return (findAnns deserialize ann_env target)

  • compiler/GHC/CmmToAsm/X86/CodeGen.hs
    ... ... @@ -6739,20 +6739,23 @@ genPopCnt bid width dst src = do
    6739 6739
    6740 6740 
         True -> do
    6741 6741 
           code_src <- getAnyReg src
    6742 
    -      src_r <- getNewRegNat format
    6742 
    +      -- Sub-word popcounts use 32-bit POPCNT, whose write zero-extends the
    6743 
    +      -- result to the full register.
    6744 
    +      src_r <- getNewRegNat (max II32 format)
    6743 6745 
           let dst_r = getRegisterReg platform  (CmmLocal dst)
    6746 
    +          -- A sub-word argument is a full Word# whose upper bits may be
    6747 
    +          -- dirty, so zero-extend it unless it visibly already is.
    6748 
    +          zx_src
    6749 
    +            | CmmMachOp (MO_UU_Conv from _) [_] <- src, from <= width
    6750 
    +            = nilOL
    6751 
    +            | otherwise
    6752 
    +            = unitOL (MOVZxL format (OpReg src_r) (OpReg src_r))
    6744 6753 
           return $ code_src src_r `appOL`
    6745 
    -          (if width == W8 then
    6746 
    -               -- The POPCNT instruction doesn't take a r/m8
    6747 
    -               unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL`
    6748 
    -               unitOL (POPCNT II16 (OpReg src_r) dst_r)
    6749 
    -           else
    6750 
    -               unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL`
    6751 6754 
               (if width == W8 || width == W16 then
    6752 
    -               -- We used a 16-bit destination register above,
    6753 
    -               -- so zero-extend
    6754 
    -               unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))
    6755 
    -           else nilOL)
    6755 
    +               zx_src `appOL`
    6756 
    +               unitOL (POPCNT II32 (OpReg src_r) dst_r)
    6757 
    +           else
    6758 
    +               unitOL (POPCNT format (OpReg src_r) dst_r))
    6756 6759
    6757 6760 
         False ->
    6758 6761 
           -- generate C call to hs_popcntN in ghc-prim

  • compiler/GHC/Core/Opt/Monad.hs
    ... ... @@ -68,9 +68,9 @@ import GHC.Unit.Module.ModGuts
    68 68 
     import GHC.Unit.External
    69 69
    70 70 
     import Data.Bifunctor ( bimap )
    71 
    +import Data.ByteString.Short ( ShortByteString )
    71 72 
     import Data.Dynamic
    72 73 
     import Data.Maybe (listToMaybe)
    73 
    -import Data.Word
    74 74 
     import Control.Monad
    75 75 
     import Control.Applicative ( Alternative(..) )
    76 76
    ... ... @@ -323,14 +323,14 @@ get_eps = do
    323 323 
     -- annotations.
    324 324 
     --
    325 325 
     -- See Note [Annotations]
    326 
    -getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a])
    326 
    +getAnnotations :: Typeable a => (ShortByteString -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a])
    327 327 
     getAnnotations deserialize guts = do
    328 328 
          hsc_env <- getHscEnv
    329 329 
          ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
    330 330 
          return (deserializeAnns deserialize ann_env)
    331 331
    332 332 
     -- | Get at most one annotation of a given type per annotatable item.
    333 
    -getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a)
    333 
    +getFirstAnnotations :: Typeable a => (ShortByteString -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a)
    334 334 
     getFirstAnnotations deserialize guts
    335 335 
       = bimap mod name <$> getAnnotations deserialize guts
    336 336 
       where

  • compiler/GHC/Tc/Gen/Splice.hs
    ... ... @@ -155,10 +155,10 @@ import Control.DeepSeq
    155 155 
     import Control.Monad
    156 156 
     import Data.Binary
    157 157 
     import Data.Binary.Get
    158 
    +import Data.ByteString.Short (ShortByteString)
    158 159 
     import Data.Containers.ListUtils ( nubOrd )
    159 160 
     import Data.List ( sortBy )
    160 161 
     import Data.Maybe
    161 
    -import qualified Data.ByteString as B
    162 162 
     import qualified Data.ByteString.Lazy as LB
    163 163 
     import Data.Dynamic  ( fromDynamic, toDyn )
    164 164 
     import qualified Data.IntMap as IntMap
    ... ... @@ -1947,7 +1947,7 @@ handleTHMessage msg = case msg of
    1947 1947 
       ReifyInstances n ts -> wrapTHResult $ runQinTcM $ TH.reifyInstances n ts
    1948 1948 
       ReifyRoles n -> wrapTHResult $ runQinTcM $ TH.reifyRoles n
    1949 1949 
       ReifyAnnotations lookup tyrep ->
    1950 
    -    wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)
    1950 
    +    wrapTHResult $ getAnnotationsByTypeRep lookup tyrep
    1951 1951 
       ReifyModule m -> wrapTHResult $ runQinTcM $ TH.reifyModule m
    1952 1952 
       ReifyConStrictness nm -> wrapTHResult $ runQinTcM $ TH.reifyConStrictness nm
    1953 1953 
       GetPackageRoot -> wrapTHResult $ runQinTcM $ TH.getPackageRoot
    ... ... @@ -1967,7 +1967,7 @@ handleTHMessage msg = case msg of
    1967 1967 
       FailIfErrs -> wrapTHResult failIfErrsM
    1968 1968 
       _ -> panic ("handleTHMessage: unexpected message " ++ show msg)
    1969 1969
    1970 
    -getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]]
    1970 
    +getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [ShortByteString]
    1971 1971 
     getAnnotationsByTypeRep th_name tyrep
    1972 1972 
       = do { name <- lookupThAnnLookup th_name
    1973 1973 
            ; topEnv <- getTopEnv

  • compiler/GHC/Types/Annotations.hs
    ... ... @@ -27,9 +27,9 @@ import GHC.Utils.Outputable
    27 27 
     import GHC.Serialized
    28 28
    29 29 
     import Control.Monad
    30 
    +import Data.ByteString.Short ( ShortByteString )
    30 31 
     import Data.Maybe
    31 32 
     import Data.Typeable
    32 
    -import Data.Word        ( Word8 )
    33 33 
     import Control.DeepSeq
    34 34
    35 35 
     -- | Represents an annotation after it has been sufficiently desugared from
    ... ... @@ -112,14 +112,14 @@ plusAnnEnv a b =
    112 112 
     -- | Find the annotations attached to the given target as 'Typeable'
    113 113 
     --   values of your choice. If no deserializer is specified,
    114 114 
     --   only transient annotations will be returned.
    115 
    -findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
    115 
    +findAnns :: Typeable a => (ShortByteString -> a) -> AnnEnv -> CoreAnnTarget -> [a]
    116 116 
     findAnns deserialize env
    117 117 
       = mapMaybe (fromSerialized deserialize) . findAnnPayloads env
    118 118
    119 119 
     -- | Find the annotations attached to the given target as 'Typeable'
    120 120 
     --   values of your choice. If no deserializer is specified,
    121 121 
     --   only transient annotations will be returned.
    122 
    -findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]]
    122 
    +findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [ShortByteString]
    123 123 
     findAnnsByTypeRep env target tyrep
    124 124 
       = [ ws | Serialized tyrep' ws <- findAnnPayloads env target
    125 125 
         , tyrep' == tyrep ]
    ... ... @@ -134,7 +134,7 @@ findAnnPayloads env target =
    134 134 
     -- | Deserialize all annotations of a given type. This happens lazily, that is
    135 135 
     --   no deserialization will take place until the [a] is actually demanded and
    136 136 
     --   the [a] can also be empty (the UniqFM is not filtered).
    137 
    -deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a])
    137 
    +deserializeAnns :: Typeable a => (ShortByteString -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a])
    138 138 
     deserializeAnns deserialize env
    139 139 
       = ( mapModuleEnv deserAnns (ann_mod_env env)
    140 140 
         , mapNameEnv deserAnns (ann_name_env env)

  • compiler/GHC/Utils/Outputable.hs
    ... ... @@ -138,6 +138,7 @@ import GHC.Utils.Misc (lastMaybe, snocView)
    138 138
    139 139 
     import Data.ByteString (ByteString)
    140 140 
     import qualified Data.ByteString as BS
    141 
    +import qualified Data.ByteString.Short as Short
    141 142 
     import Data.Char
    142 143 
     import qualified Data.Map as M
    143 144 
     import Data.Int
    ... ... @@ -1105,7 +1106,7 @@ instance Outputable a => Outputable (SCC a) where
    1105 1106 
        ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs)))
    1106 1107
    1107 1108 
     instance Outputable Serialized where
    1108 
    -    ppr (Serialized the_type bytes) = int (length bytes) <+> text "of type" <+> text (show the_type)
    1109 
    +    ppr (Serialized the_type bytes) = int (Short.length bytes) <+> text "of type" <+> text (show the_type)
    1109 1110
    1110 1111 
     instance Outputable Extension where
    1111 1112 
         ppr = text . show

  • libraries/ghc-boot/GHC/Serialized.hs
    ... ... @@ -19,144 +19,68 @@ module GHC.Serialized (
    19 19 
       ) where
    20 20
    21 21 
     import Prelude -- See note [Why do we import Prelude here?]
    22 
    -import Data.Bits
    23 
    -import Data.Word        ( Word8 )
    24 
    -import Data.Data
    25 22 
     import Control.DeepSeq
    23 
    +import Data.Binary
    24 
    +import Data.Binary.Get
    25 
    +import Data.Binary.Put
    26 
    +import Data.ByteString.Short (ShortByteString)
    27 
    +import qualified Data.ByteString.Short as Short
    28 
    +import qualified Data.ByteString.Lazy as ByteString.Lazy
    29 
    +import Data.Data
    26 30
    27 31
    28 32 
     -- | Represents a serialized value of a particular type. Attempts can be made to deserialize it at certain types
    29 
    -data Serialized = Serialized TypeRep [Word8]
    33 
    +data Serialized = Serialized TypeRep ShortByteString
    30 34
    31 35 
     instance NFData Serialized where
    32 36 
       rnf (Serialized tr ws) = rnf tr `seq` rnf ws
    33 37
    34 38 
     -- | Put a Typeable value that we are able to actually turn into bytes into a 'Serialized' value ready for deserialization later
    35 
    -toSerialized :: forall a. Typeable a => (a -> [Word8]) -> a -> Serialized
    39 
    +toSerialized :: forall a. Typeable a => (a -> ShortByteString) -> a -> Serialized
    36 40 
     toSerialized serialize what = Serialized (typeOf what) (serialize what)
    37 41
    38 42 
     -- | If the 'Serialized' value contains something of the given type, then use the specified deserializer to return @Just@ that.
    39 43 
     -- Otherwise return @Nothing@.
    40 
    -fromSerialized :: forall a. Typeable a => ([Word8] -> a) -> Serialized -> Maybe a
    44 
    +fromSerialized :: forall a. Typeable a => (ShortByteString -> a) -> Serialized -> Maybe a
    41 45 
     fromSerialized deserialize (Serialized the_type bytes)
    42 46 
       | the_type == rep = Just (deserialize bytes)
    43 47 
       | otherwise       = Nothing
    44 48 
       where rep = typeRep (Proxy :: Proxy a)
    45 49
    46 50 
     -- | Use a 'Data' instance to implement a serialization scheme dual to that of 'deserializeWithData'
    47 
    -serializeWithData :: Data a => a -> [Word8]
    48 
    -serializeWithData what = serializeWithData' what []
    49 
    -
    50 
    -serializeWithData' :: Data a => a -> [Word8] -> [Word8]
    51 
    -serializeWithData' what = fst $ gfoldl (\(before, a_to_b) a -> (before . serializeWithData' a, a_to_b a))
    52 
    -                                       (\x -> (serializeConstr (constrRep (toConstr what)), x))
    53 
    -                                       what
    51 
    +serializeWithData :: Data a => a -> ShortByteString
    52 
    +serializeWithData = Short.toShort . ByteString.Lazy.toStrict . runPut . putData
    54 53
    55 54 
     -- | Use a 'Data' instance to implement a deserialization scheme dual to that of 'serializeWithData'
    56 
    -deserializeWithData :: Data a => [Word8] -> a
    57 
    -deserializeWithData = snd . deserializeWithData'
    58 
    -
    59 
    -deserializeWithData' :: forall a. Data a => [Word8] -> ([Word8], a)
    60 
    -deserializeWithData' bytes = deserializeConstr bytes $ \constr_rep bytes ->
    61 
    -                             gunfold (\(bytes, b_to_r) -> let (bytes', b) = deserializeWithData' bytes in (bytes', b_to_r b))
    62 
    -                                     (\x -> (bytes, x))
    63 
    -                                     (repConstr (dataTypeOf (undefined :: a)) constr_rep)
    64 
    -
    65 
    -
    66 
    -serializeConstr :: ConstrRep -> [Word8] -> [Word8]
    67 
    -serializeConstr (AlgConstr ix)   = serializeWord8 1 . serializeInt ix
    68 
    -serializeConstr (IntConstr i)    = serializeWord8 2 . serializeInteger i
    69 
    -serializeConstr (FloatConstr r)  = serializeWord8 3 . serializeRational r
    70 
    -serializeConstr (CharConstr c)   = serializeWord8 4 . serializeChar c
    71 
    -
    72 
    -
    73 
    -deserializeConstr :: [Word8] -> (ConstrRep -> [Word8] -> a) -> a
    74 
    -deserializeConstr bytes k = deserializeWord8 bytes $ \constr_ix bytes ->
    75 
    -                            case constr_ix of
    76 
    -                                1 -> deserializeInt      bytes $ \ix -> k (AlgConstr ix)
    77 
    -                                2 -> deserializeInteger  bytes $ \i  -> k (IntConstr i)
    78 
    -                                3 -> deserializeRational bytes $ \r  -> k (FloatConstr r)
    79 
    -                                4 -> deserializeChar     bytes $ \c  -> k (CharConstr c)
    80 
    -                                x -> error $ "deserializeConstr: unrecognised serialized constructor type " ++ show x ++ " in context " ++ show bytes
    81 
    -
    82 
    -
    83 
    -serializeFixedWidthNum :: forall a. (Integral a, FiniteBits a) => a -> [Word8] -> [Word8]
    84 
    -serializeFixedWidthNum what = go (finiteBitSize what) what
    85 
    -  where
    86 
    -    go :: Int -> a -> [Word8] -> [Word8]
    87 
    -    go size current rest
    88 
    -      | size <= 0 = rest
    89 
    -      | otherwise = fromIntegral (current .&. 255) : go (size - 8) (current `shiftR` 8) rest
    90 
    -
    91 
    -deserializeFixedWidthNum :: forall a b. (Integral a, FiniteBits a) => [Word8] -> (a -> [Word8] -> b) -> b
    92 
    -deserializeFixedWidthNum bytes k = go (finiteBitSize (undefined :: a)) bytes k
    93 
    -  where
    94 
    -    go :: Int -> [Word8] -> (a -> [Word8] -> b) -> b
    95 
    -    go size bytes k
    96 
    -      | size <= 0 = k 0 bytes
    97 
    -      | otherwise = case bytes of
    98 
    -                        (byte:bytes) -> go (size - 8) bytes (\x -> k ((x `shiftL` 8) .|. fromIntegral byte))
    99 
    -                        []           -> error "deserializeFixedWidthNum: unexpected end of stream"
    100 
    -
    101 
    -
    102 
    -serializeEnum :: (Enum a) => a -> [Word8] -> [Word8]
    103 
    -serializeEnum = serializeInt . fromEnum
    104 
    -
    105 
    -deserializeEnum :: Enum a => [Word8] -> (a -> [Word8] -> b) -> b
    106 
    -deserializeEnum bytes k = deserializeInt bytes (k . toEnum)
    107 
    -
    108 
    -
    109 
    -serializeWord8 :: Word8 -> [Word8] -> [Word8]
    110 
    -serializeWord8 x = (x:)
    111 
    -
    112 
    -deserializeWord8 :: [Word8] -> (Word8 -> [Word8] -> a) -> a
    113 
    -deserializeWord8 (byte:bytes) k = k byte bytes
    114 
    -deserializeWord8 []           _ = error "deserializeWord8: unexpected end of stream"
    115 
    -
    116 
    -
    117 
    -serializeInt :: Int -> [Word8] -> [Word8]
    118 
    -serializeInt = serializeFixedWidthNum
    119 
    -
    120 
    -deserializeInt :: [Word8] -> (Int -> [Word8] -> a) -> a
    121 
    -deserializeInt = deserializeFixedWidthNum
    122 
    -
    123 
    -
    124 
    -serializeRational :: (Real a) => a -> [Word8] -> [Word8]
    125 
    -serializeRational = serializeString . show . toRational
    126 
    -
    127 
    -deserializeRational :: (Fractional a) => [Word8] -> (a -> [Word8] -> b) -> b
    128 
    -deserializeRational bytes k = deserializeString bytes (k . fromRational . read)
    129 
    -
    130 
    -
    131 
    -serializeInteger :: Integer -> [Word8] -> [Word8]
    132 
    -serializeInteger = serializeString . show
    133 
    -
    134 
    -deserializeInteger :: [Word8] -> (Integer -> [Word8] -> a) -> a
    135 
    -deserializeInteger bytes k = deserializeString bytes (k . read)
    136 
    -
    137 
    -
    138 
    -serializeChar :: Char -> [Word8] -> [Word8]
    139 
    -serializeChar = serializeString . show
    140 
    -
    141 
    -deserializeChar :: [Word8] -> (Char -> [Word8] -> a) -> a
    142 
    -deserializeChar bytes k = deserializeString bytes (k . read)
    143 
    -
    144 
    -
    145 
    -serializeString :: String -> [Word8] -> [Word8]
    146 
    -serializeString = serializeList serializeEnum
    147 
    -
    148 
    -deserializeString :: [Word8] -> (String -> [Word8] -> a) -> a
    149 
    -deserializeString = deserializeList deserializeEnum
    150 
    -
    151 
    -
    152 
    -serializeList :: (a -> [Word8] -> [Word8]) -> [a] -> [Word8] -> [Word8]
    153 
    -serializeList serialize_element xs = serializeInt (length xs) . foldr (.) id (map serialize_element xs)
    154 
    -
    155 
    -deserializeList :: forall a b. (forall c. [Word8] -> (a -> [Word8] -> c) -> c)
    156 
    -                -> [Word8] -> ([a] -> [Word8] -> b) -> b
    157 
    -deserializeList deserialize_element bytes k = deserializeInt bytes $ \len bytes -> go len bytes k
    158 
    -  where
    159 
    -    go :: Int -> [Word8] -> ([a] -> [Word8] -> b) -> b
    160 
    -    go len bytes k
    161 
    -      | len <= 0  = k [] bytes
    162 
    -      | otherwise = deserialize_element bytes (\elt bytes -> go (len - 1) bytes (k . (elt:)))
    55 
    +deserializeWithData :: Data a => ShortByteString -> a
    56 
    +deserializeWithData bs =
    57 
    +  case runGetOrFail getData (ByteString.Lazy.fromStrict (Short.fromShort bs)) of
    58 
    +    Right (_, _, x)    -> x
    59 
    +    Left (_, off, msg) ->
    60 
    +      error ("deserializeWithData: " ++ msg ++ " at offset " ++ show off)
    61 
    +
    62 
    +putData :: Data a => a -> Put
    63 
    +putData x = do
    64 
    +  putConstrRep (constrRep (toConstr x))
    65 
    +  sequence_ (gmapQ putData x)
    66 
    +
    67 
    +getData :: forall a. Data a => Get a
    68 
    +getData = do
    69 
    +  rep <- getConstrRep
    70 
    +  fromConstrM getData (repConstr (dataTypeOf (undefined :: a)) rep)
    71 
    +
    72 
    +putConstrRep :: ConstrRep -> Put
    73 
    +putConstrRep (AlgConstr ix)  = putWord8 1 >> put ix
    74 
    +putConstrRep (IntConstr i)   = putWord8 2 >> put i
    75 
    +putConstrRep (FloatConstr r) = putWord8 3 >> put r
    76 
    +putConstrRep (CharConstr c)  = putWord8 4 >> put c
    77 
    +
    78 
    +getConstrRep :: Get ConstrRep
    79 
    +getConstrRep = do
    80 
    +  tag <- getWord8
    81 
    +  case tag of
    82 
    +    1 -> AlgConstr   <$> get
    83 
    +    2 -> IntConstr   <$> get
    84 
    +    3 -> FloatConstr <$> get
    85 
    +    4 -> CharConstr  <$> get
    86 
    +    _ -> fail ("unrecognised constructor tag " ++ show tag)

  • libraries/ghci/GHCi/Message.hs
    ... ... @@ -297,7 +297,7 @@ data THMessage a where
    297 297 
       ReifyInstances :: TH.Name -> [TH.Type] -> THMessage (THResult [TH.Dec])
    298 298 
       ReifyRoles :: TH.Name -> THMessage (THResult [TH.Role])
    299 299 
       ReifyAnnotations :: TH.AnnLookup -> TypeRep
    300 
    -    -> THMessage (THResult [ByteString])
    300 
    +    -> THMessage (THResult [BS.ShortByteString])
    301 301 
       ReifyModule :: TH.Module -> THMessage (THResult TH.ModuleInfo)
    302 302 
       ReifyConStrictness :: TH.Name -> THMessage (THResult [TH.DecidedStrictness])
    303 303

  • libraries/ghci/GHCi/TH.hs
    ... ... @@ -100,7 +100,6 @@ import Control.Monad.IO.Class (MonadIO (..))
    100 100 
     import Data.Binary
    101 101 
     import Data.Binary.Put
    102 102 
     import Data.ByteString (ByteString)
    103 
    -import qualified Data.ByteString as B
    104 103 
     import qualified Data.ByteString.Lazy as LB
    105 104 
     import Data.Data
    106 105 
     import Data.Dynamic
    ... ... @@ -169,7 +168,7 @@ instance MonadIO GHCiQ where
    169 168 
       -- serialize irrelevant annotations.
    170 169 
     reifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
    171 170 
     reifyAnnotations lookup =
    172 
    -    map (deserializeWithData . B.unpack) <$>
    171 
    +    map deserializeWithData <$>
    173 172 
           ghcCmd (ReifyAnnotations lookup typerep)
    174 173 
         where typerep = typeOf (undefined :: a)
    175 174

  • libraries/ghci/GHCi/TH/Binary.hs
    ... ... @@ -9,7 +9,6 @@ module GHCi.TH.Binary () where
    9 9
    10 10 
     import Prelude -- See note [Why do we import Prelude here?]
    11 11 
     import Data.Binary
    12 
    -import qualified Data.ByteString as B
    13 12 
     import qualified Data.ByteString.Internal as B
    14 13 
     import GHC.Serialized
    15 14 
     import qualified GHC.Boot.TH.Syntax as TH
    ... ... @@ -74,8 +73,8 @@ instance Binary TH.DocLoc
    74 73 
     -- We need Binary TypeRep for serializing annotations
    75 74
    76 75 
     instance Binary Serialized where
    77 
    -    put (Serialized tyrep wds) = put tyrep >> put (B.pack wds)
    78 
    -    get = Serialized <$> get <*> (B.unpack <$> get)
    76 
    +    put (Serialized tyrep wds) = put tyrep >> put wds
    77 
    +    get = Serialized <$> get <*> get
    79 78
    80 79 
     instance Binary TH.Bytes where
    81 80 
        put (TH.Bytes ptr off sz) = put bs

  • rts/RtsUtils.c
    ... ... @@ -397,6 +397,7 @@ void printRtsInfo(const RtsConfig rts_config) {
    397 397 
             rts_config.rts_opts != NULL ? rts_config.rts_opts : "");
    398 398 
         selectIOManager(); /* resolve the io-manager, accounting for flags  */
    399 399 
         mkRtsInfoPair("I/O manager default",     showIOManager());
    400 
    +    mkRtsInfoPair("I/O managers",            &IOMGRS_ENABLED_STR[1]); // skips the initial ' ' character in IOMGRS_ENABLED_STR
    400 401 
         printf(" ]\n");
    401 402 
     }
    402 403

  • testsuite/config/ghc
    ... ... @@ -257,7 +257,9 @@ def get_compiler_info():
    257 257 
                         )
    258 258
    259 259 
                 except Exception as err:
    260 
    -                print("Exception thrown in testsuite/config/ghc.get_compiler_info: %s", err)
    260 
    +                # We don't throw so that we can still discover tests before we've built
    261 
    +                # GHC (i.e. config.compiler doesn't yet exist).
    262 
    +                print("Exception thrown in testsuite/config/ghc.get_compiler_info: ", err)
    261 263
    262 264 
                 else:
    263 265 
                     res = p.returncode == 0
    ... ... @@ -315,6 +317,58 @@ def get_compiler_info():
    315 317 
             config.ghc_th_way       = "normal"
    316 318 
             config.ghc_th_hi_ext    = "hi"
    317 319
    320 
    +    # I/O manager discovery.
    321 
    +    #
    322 
    +    # Which I/O managers (GHC's `--io-manager` RTS flag) a given RTS build
    323 
    +    # supports depends on the target platform and on whether the RTS is the
    324 
    +    # threaded or non-threaded flavour (see rts/IOManager.h's
    325 
    +    # IOMGR_ENABLED_* macros). Rather than duplicate that platform/way
    326 
    +    # dependent logic here, we ask the RTS itself using `+RTS --info -RTS`
    327 
    +    # and extract the "I/O managers" value from stdout.
    328 
    +    def discover_io_managers_generic(extra_flags):
    329 
    +        import tempfile
    330 
    +
    331 
    +        test_src = 'main :: IO ()\nmain = return ()\n'
    332 
    +
    333 
    +        res = [None]
    334 
    +
    335 
    +        with tempfile.TemporaryDirectory() as d:
    336 
    +            src = Path(d) / 'IOMgrProbe.hs'
    337 
    +            src.write_text(test_src)
    338 
    +            exe = Path(d) / ('IoMgrProbe' + config.exeext)
    339 
    +
    340 
    +            # -rtsopts is needed so that the resulting binary will even
    341 
    +            # consider an --io-manager= flag (rather than immediately
    342 
    +            # rejecting all "unsafe" RTS options).
    343 
    +            cmd = '{} -v0 -rtsopts -o {} {} {}'.format(
    344 
    +                                    config.compiler,
    345 
    +                                    exe,
    346 
    +                                    src,
    347 
    +                                    ' '.join(extra_flags))
    348 
    +            try:
    349 
    +                cp = subprocess.run(
    350 
    +                    cmd,
    351 
    +                    shell=True,
    352 
    +                    cwd=d,
    353 
    +                    stdout=subprocess.DEVNULL,
    354 
    +                    stderr=None if config.verbose >= 3 else subprocess.DEVNULL)
    355 
    +                if cp.returncode != 0 or not exe.exists():
    356 
    +                    raise Exception("Error in testsuite/config/ghc.discover_io_managers: failed to compile with: {}".format(cmd))
    357 
    +                res = list(discover_io_managers(exe, d))
    358 
    +
    359 
    +            except Exception as err:
    360 
    +                # We don't throw so that we can still discover tests before we've built
    361 
    +                # GHC (i.e. config.compiler doesn't yet exist).
    362 
    +                print("Exception thrown in testsuite/config/ghc.discover_io_managers_generic: ", err)
    363 
    +
    364 
    +        return res
    365 
    +
    366 
    +    config.io_managers_nonthreaded = discover_io_managers_generic([])
    367 
    +    config.io_managers_threaded = (
    368 
    +        discover_io_managers_generic(['-threaded']) if config.ghc_with_threaded_rts
    369 
    +        else [])
    370 
    +    config.io_managers_all = list(set(config.io_managers_nonthreaded).union(set(config.io_managers_threaded)))
    371 
    +
    318 372 
         config.cmm_cpp_is_gcc = test_compile(
    319 373 
             ['-c'],
    320 374 
             test_filename='test.cmm',

  • testsuite/driver/runtests.py
    ... ... @@ -28,7 +28,7 @@ import subprocess
    28 28
    29 29 
     import asyncio
    30 30
    31 
    -from testutil import getStdout, str_warn, str_info, print_table, shorten_metric_name, str_removeprefix
    31 
    +from testutil import discover_io_managers, getStdout, str_warn, str_info, print_table, shorten_metric_name, str_removeprefix
    32 32 
     from testglobals import getConfig, ghc_env, TestConfig, t, \
    33 33 
                             TestOptions, brokens, PerfMetric
    34 34 
     from my_typing import TestName

  • testsuite/driver/testglobals.py
    ... ... @@ -126,6 +126,15 @@ class TestConfig:
    126 126 
             self.way_flags = {}  # type: Dict[WayName, List[str]]
    127 127 
             self.way_rts_flags = {}  # type: Dict[WayName, List[str]]
    128 128
    129 
    +        # I/O managers (GHC's `--io-manager` RTS flag) supported by the threaded runtime.
    130 
    +        self.io_managers_threaded = []  # type: List[str]
    131 
    +
    132 
    +        # I/O managers (GHC's `--io-manager` RTS flag) supported by the non-threaded runtime.
    133 
    +        self.io_managers_nonthreaded = []  # type: List[str]
    134 
    +
    135 
    +        # All I/O managers (GHC's `--io-manager` RTS flag)
    136 
    +        self.io_managers_all = []  # type: List[str]
    137 
    +
    129 138 
             # Do we have a functional LLVM toolchain?
    130 139 
             self.have_llvm = False
    131 140
    ... ... @@ -227,7 +236,7 @@ class TestConfig:
    227 236 
             self.allowed_perf_changes = {}
    228 237
    229 238 
             # The test environment.
    230 
    -        self.test_env = 'local'
    239 
    +        self.test_env = TestEnv('local')
    231 240
    232 241 
             # terminal supports colors
    233 242 
             self.supports_colors = False
    ... ... @@ -367,6 +376,14 @@ class TestOptions:
    367 376 
            # add these ways to the default set
    368 377 
            self.extra_ways = [] # type: List[WayName]
    369 378
    379 
    +       # IO Managers to test (passed as the --io-manager RTS option)
    380 
    +       # * [None] - only default IO Manager
    381 
    +       # * [...] - list of io managers e.g. "mio" or "poll"
    382 
    +       self.io_managers = [None] # type: List[Optional[str]]
    383 
    +
    384 
    +       # IO Manager used in the current test case. Set before each test case. None means default IO Manager
    385 
    +       self.io_manager_current = None # type: Optional[str]
    386 
    +
    370 387 
            # the result we normally expect for this test
    371 388 
            self.expect = 'pass'
    372 389

  • testsuite/driver/testlib.py
    ... ... @@ -23,7 +23,7 @@ import subprocess
    23 23
    24 24 
     from testglobals import config, ghc_env, default_testopts, brokens, t, \
    25 25 
                             TestRun, TestResult, TestOptions, PerfMetric
    26 
    -from testutil import strip_quotes, lndir, link_or_copy_file, passed, \
    26 
    +from testutil import discover_io_managers, strip_quotes, lndir, link_or_copy_file, passed, \
    27 27 
                          failBecause, residency_testing_metrics, \
    28 28 
                          stable_perf_counters, \
    29 29 
                          PassFail, badResult, str_warn, str_removeprefix
    ... ... @@ -190,7 +190,7 @@ def no_lint( name, opts ):
    190 190
    191 191 
     def stage1(name, opts):
    192 192 
         # See Note [Why is there no stage1 setup function?]
    193 
    -    framework_fail(name, 'stage1 setup function does not exist',
    193 
    +    framework_fail(name, None,
    194 194 
                        'add your test to testsuite/tests/stage1 instead')
    195 195
    196 196 
     # Note [Why is there no stage1 setup function?]
    ... ... @@ -341,7 +341,7 @@ def req_th( name, opts ):
    341 341 
         req_interp(name, opts);
    342 342
    343 343 
         if ghc_dynamic():
    344 
    -        return _omit_ways(name, opts, ['profasm', 'profthreaded'])
    344 
    +        return _omit_ways(name, opts, [WayName('profasm'), WayName('profthreaded')])
    345 345
    346 346 
     def req_plugins( name, opts ):
    347 347 
         """
    ... ... @@ -355,7 +355,7 @@ def req_plugins( name, opts ):
    355 355 
         req_interp(name, opts)
    356 356
    357 357 
         # Plugins aren't supported with the external interpreter (#14335)
    358 
    -    expect_broken_for(14335,['ext-interp'])(name,opts)
    358 
    +    expect_broken_for(IssueNumber(14335),[WayName('ext-interp')])(name,opts)
    359 359
    360 360 
         if config.cross:
    361 361 
             opts.skip = True
    ... ... @@ -569,6 +569,34 @@ def extra_ways( ways: List[WayName] ):
    569 569
    570 570 
         return helper
    571 571
    572 
    +# -----
    573 
    +
    574 
    +def _io_managers( name: TestName, opts, io_mgrs: List[str] ) -> None:
    575 
    +    opts.io_managers = io_mgrs
    576 
    +
    577 
    +def io_managers( io_mgrs: List[str] ):
    578 
    +    """
    579 
    +    Further split test cases into the given IO Managers if available.
    580 
    +    Available IO Managers are determined by the test case's way (threaded/non-threads) and OS.
    581 
    +    You'll likely want to use `extra_ways(['threaded2'])` if you want to test threaded IO Managers (e.g. mio).
    582 
    +    """
    583 
    +    return lambda name, opts: _io_managers(name, opts, io_mgrs)
    584 
    +
    585 
    +def all_available_io_managers( name: TestName, opts ):
    586 
    +    """
    587 
    +    Further split test cases into all available IO Managers.
    588 
    +    Available IO Managers are determined by the test case's way (threaded/non-threads) and OS.
    589 
    +    You'll likely want to use `extra_ways(['threaded2'])` to ensure threaded IO Managers are tested (e.g. mio).
    590 
    +    """
    591 
    +    _io_managers(name, opts, config.io_managers_all)
    592 
    +
    593 
    +def all_available_io_managers_except(exclude: List[str]):
    594 
    +    """
    595 
    +    Further split test cases into all available (except the given excluded) IO Managers.
    596 
    +    Available IO Managers are determined by the test case's way (threaded/non-threads) and OS.
    597 
    +    You'll likely want to use `extra_ways(['threaded2'])` to ensure threaded IO Managers are tested (e.g. mio).
    598 
    +    """
    599 
    +    return lambda name, opts: _io_managers(name, opts, list(set(config.io_managers_all) - set(exclude)))
    572 600
    573 601 
     # -----
    574 602
    ... ... @@ -661,18 +689,15 @@ def collect_size ( deviation, path ):
    661 689 
     def collect_size_func ( deviation, path_func ):
    662 690 
         return collect_generic_stat ( 'size', deviation, lambda way: os.path.getsize(in_testdir(path_func())) )
    663 691
    664 
    -def get_dir_size(path):
    692 
    +def get_dir_size(path) -> int:
    665 693 
         total = 0
    666 
    -    try:
    667 
    -        with os.scandir(path) as it:
    668 
    -            for entry in it:
    669 
    -                if entry.is_file():
    670 
    -                    total += entry.stat().st_size
    671 
    -                elif entry.is_dir():
    672 
    -                    total += get_dir_size(entry.path)
    673 
    -        return total
    674 
    -    except FileNotFoundError:
    675 
    -        print("Exception: Could not find: " + path)
    694 
    +    with os.scandir(path) as it:
    695 
    +        for entry in it:
    696 
    +            if entry.is_file():
    697 
    +                total += entry.stat().st_size
    698 
    +            elif entry.is_dir():
    699 
    +                total += get_dir_size(entry.path)
    700 
    +    return total
    676 701
    677 702 
     def collect_size_dir ( deviation, path ):
    678 703 
         return collect_size_dir_func ( deviation, lambda: path )
    ... ... @@ -790,7 +815,7 @@ def find_non_inplace_so(lib):
    790 815 
         return _find_so(lib,path_from_ghcPkg(lib, "dynamic-library-dirs"),False)
    791 816
    792 817
    793 
    -def collect_generic_stat ( metric, deviation: Optional[int], get_stat: Callable[[WayName], str]):
    818 
    +def collect_generic_stat ( metric, deviation: Optional[int], get_stat: Callable[[WayName], Any]):
    794 819 
         """
    795 820 
         Define a generic stat test, which computes the statistic by calling the function
    796 821 
         given as the third argument.
    ... ... @@ -1135,7 +1160,7 @@ def _collect_compiler_perf_counters(counters: Set[str], deviation: Optional[int]
    1135 1160 
             # Slightly hacky, we need the requested perf_counters in 'simple_run'.
    1136 1161 
             # Thus, we have to globally register these counters
    1137 1162 
             opts.compiler_perf_counters += list(counters)
    1138 
    -        _collect_stats(name, opts, counters, deviation, False, True, True)
    1163 
    +        _collect_stats(name, opts, counters, deviation, None, True, True)
    1139 1164 
         return f
    1140 1165
    1141 1166
    ... ... @@ -1334,21 +1359,22 @@ def check_errmsg(needle):
    1334 1359 
     # grep_errmsg(regex,[groups])
    1335 1360 
     # If groups are given, return only the matched groups
    1336 1361 
     # that matches the regex.
    1337 
    -def grep_errmsg_norm(needle:str, groups = None):
    1338 
    -
    1339 
    -    def get_match(str:str):
    1340 
    -        m = re.search(needle,str)
    1341 
    -        if m:
    1342 
    -            return "".join([m.group(g) for g in groups if m.group(g) is not None])
    1343 
    -        else:
    1344 
    -            return None
    1362 
    +def grep_errmsg_norm(needle:str, groups_may = None):
    1345 1363
    1346 
    -    def norm(str) -> str:
    1347 
    -        if groups == None:
    1364 
    +    def norm(string) -> str:
    1365 
    +        if groups_may == None:
    1348 1366 
                 return "".join( filter(lambda l: re.search(needle,l),
    1349 
    -                                   str.splitlines(True)))
    1367 
    +                                   string.splitlines(True)))
    1350 1368 
             else:
    1351 
    -            matches = [get_match(x) for x in str.splitlines(True)]
    1369 
    +            groups = groups_may
    1370 
    +            def get_match(string: str):
    1371 
    +                m = re.search(needle, string)
    1372 
    +                if m:
    1373 
    +                    return "".join([m.group(g) for g in groups if m.group(g) is not None])
    1374 
    +                else:
    1375 
    +                    return None
    1376 
    +
    1377 
    +            matches = [get_match(x) for x in string.splitlines(True)]
    1352 1378 
                 res = "\n".join([x for x in matches if x])
    1353 1379 
                 return res
    1354 1380 
         return norm
    ... ... @@ -1573,6 +1599,15 @@ do_not_copy = ('.hi', '.o', '.dyn_hi'
    1573 1599 
                   , '.dyn_o', '.out'
    1574 1600 
                   ,'.hi-boot', '.o-boot') # 12112
    1575 1601
    1602 
    +def way_supports_io_manager(way: WayName, io_manager: Optional[str]) -> bool:
    1603 
    +    # All ways support a default IO Manager
    1604 
    +    if io_manager is None:
    1605 
    +        return True
    1606 
    +
    1607 
    +    way_is_threaded = '-threaded' in config.way_flags[way]
    1608 
    +    available_io_managers = config.io_managers_threaded if way_is_threaded else config.io_managers_nonthreaded
    1609 
    +    return io_manager in available_io_managers
    1610 
    +
    1576 1611 
     async def test_common_work(name: TestName, opts,
    1577 1612 
                          func, args) -> None:
    1578 1613 
         try:
    ... ... @@ -1621,7 +1656,22 @@ async def test_common_work(name: TestName, opts,
    1621 1656 
             # A test itself can request extra ways by setting opts.extra_ways
    1622 1657 
             all_ways = list(OrderedDict.fromkeys(all_ways + [way for way in opts.extra_ways if way not in all_ways]))
    1623 1658
    1624 
    -        t.total_test_cases += len(all_ways)
    1659 
    +        # We split each way over available io managers
    1660 
    +        if len(opts.io_managers) == 0:
    1661 
    +            framework_fail(name, None, 'opts.io_managers is empty')
    1662 
    +        all_ways_and_io_managers = dict(
    1663 
    +            (
    1664 
    +                way,
    1665 
    +                [io_manager
    1666 
    +                    for io_manager in opts.io_managers
    1667 
    +                    if way_supports_io_manager(way, io_manager)
    1668 
    +                ]
    1669 
    +            )
    1670 
    +            for way in all_ways
    1671 
    +        )
    1672 
    +
    1673 
    +        for io_managers in all_ways_and_io_managers.values():
    1674 
    +            t.total_test_cases += len(io_managers)
    1625 1675
    1626 1676 
             only_ways = getTestOpts().only_ways
    1627 1677 
             ok_way = lambda way: \
    ... ... @@ -1704,19 +1754,23 @@ async def test_common_work(name: TestName, opts,
    1704 1754
    1705 1755 
             # Run the required tests...
    1706 1756 
             for way in do_ways:
    1707 
    -            if stopping():
    1708 
    -                break
    1709 
    -            start = time.monotonic()
    1710 
    -            try:
    1711 
    -                await do_test(name, way, func, args, files)
    1712 
    -            except KeyboardInterrupt:
    1713 
    -                stopNow()
    1714 
    -            except Exception as e:
    1715 
    -                traceback.print_exc()
    1716 
    -                framework_fail(name, way, traceback.format_exc(),
    1717 
    -                               runtime=time.monotonic() - start)
    1757 
    +            for io_manager in all_ways_and_io_managers[way]:
    1758 
    +                if stopping():
    1759 
    +                    break
    1760 
    +                start = time.monotonic()
    1761 
    +                try:
    1762 
    +                    getTestOpts().io_manager_current = io_manager
    1763 
    +                    await do_test(name ,way ,func ,args ,files)
    1764 
    +                except KeyboardInterrupt:
    1765 
    +                    stopNow()
    1766 
    +                except Exception as e:
    1767 
    +                    traceback.print_exc()
    1768 
    +                    framework_fail(name, way, traceback.format_exc(),
    1769 
    +                                runtime=time.monotonic() - start)
    1770 
    +
    1771 
    +        for skipped_way in set(all_ways) - set(do_ways):
    1772 
    +            t.n_tests_skipped += len(all_ways_and_io_managers[skipped_way])
    1718 1773
    1719 
    -        t.n_tests_skipped += len(set(all_ways) - set(do_ways))
    1720 1774 
             if getTestOpts().expect == 'missing-lib': t.n_missing_libs += 1
    1721 1775
    1722 1776 
             if config.cleanup and do_ways:
    ... ... @@ -1743,6 +1797,8 @@ async def do_test(name: TestName,
    1743 1797 
         start = time.monotonic()
    1744 1798
    1745 1799 
         full_name = name + '(' + way + ')'
    1800 
    +    if opts.io_manager_current is not None:
    1801 
    +        full_name += ' (IO Manager: {})'.format(opts.io_manager_current)
    1746 1802 
         test_n = len(allTestNames)
    1747 1803 
         progress_args = [ full_name, t.total_tests, test_n,
    1748 1804 
             [len(t.unexpected_passes),
    ... ... @@ -1925,7 +1981,7 @@ def framework_warn(name: TestName, way: WayName, reason: str) -> None:
    1925 1981 
     # run_command.
    1926 1982
    1927 1983 
     async def run_command( name, way, cmd ):
    1928 
    -    return await simple_run( name, '', override_options(cmd), '' )
    1984 
    +    return await simple_run( name, WayName(''), override_options(cmd), '' )
    1929 1985
    1930 1986 
     async def makefile_test( name, way, target=None ):
    1931 1987 
         if target is None:
    ... ... @@ -2011,7 +2067,7 @@ async def multi_compile_fail( name, way, top_mod, extra_mods, extra_hc_opts ):
    2011 2067 
         return await do_compile( name, way, True, top_mod, extra_mods, [], extra_hc_opts)
    2012 2068
    2013 2069 
     async def make_depend( name, way, mods, extra_hc_opts ):
    2014 
    -    return await do_compile( name, way, False,  ' '.join(mods), [], [], extra_hc_opts, mode = '-M')
    2070 
    +    return await do_compile( name, way, False, Path(' '.join(mods)), [], [], extra_hc_opts, mode = '-M')
    2015 2071
    2016 2072 
     async def do_compile(name: TestName,
    2017 2073 
                    way: WayName,
    ... ... @@ -2142,7 +2198,7 @@ async def compile_grep_core(name: TestName,
    2142 2198
    2143 2199 
     async def compile_and_run__(name: TestName,
    2144 2200 
                           way: WayName,
    2145 
    -                      top_mod: Path,
    2201 
    +                      top_mod: Optional[Path],
    2146 2202 
                           extra_mods: List[str],
    2147 2203 
                           extra_hc_opts: str,
    2148 2204 
                           backpack: bool=False,
    ... ... @@ -2425,6 +2481,9 @@ async def simple_run(name: TestName, way: WayName, prog: str, extra_run_opts: st
    2425 2481
    2426 2482 
         my_rts_flags = rts_flags(way)
    2427 2483
    2484 
    +    if opts.io_manager_current is not None:
    2485 
    +        my_rts_flags += ' +RTS --io-manager={0} -RTS '.format(opts.io_manager_current)
    2486 
    +
    2428 2487 
         # Collect runtime stats if necessary:
    2429 2488 
         # isStatsTest and not isCompilerStatsTest():
    2430 2489 
         #   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
    2450 2509
    2451 2510 
         output_file = perfStatsFile(False, name)
    2452 2511
    2512 
    +    # Check that IO Manager is available
    2513 
    +    if opts.io_manager_current is not None:
    2514 
    +        available_io_managers = discover_io_managers(prog, opts.testdir)
    2515 
    +        if opts.io_manager_current not in available_io_managers:
    2516 
    +            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))
    2517 
    +
    2453 2518 
         # run the command
    2454 2519 
         exit_code = await runCmdPerf(opts.compiler_perf_counters, cmd, output_file,
    2455 2520 
             working_dir=opts.testdir,
    ... ... @@ -2511,7 +2576,7 @@ def rts_flags(way: WayName) -> str:
    2511 2576 
     async def interpreter_run(name: TestName,
    2512 2577 
                         way: WayName,
    2513 2578 
                         extra_hc_opts: str,
    2514 
    -                    top_mod: Path
    2579 
    +                    top_mod: Optional[Path]
    2515 2580 
                         ) -> PassFail:
    2516 2581 
         opts = getTestOpts()
    2517 2582
    ... ... @@ -2882,11 +2947,11 @@ async def compare_outputs(
    2882 2947 
                 if config.accept_platform:
    2883 2948 
                     if_verbose(1, 'Accepting new output for platform "'
    2884 2949 
                                   + config.platform + '".')
    2885 
    -                expected_path += '-' + config.platform
    2950 
    +                expected_path = Path(str(expected_path) + '-' + config.platform)
    2886 2951 
                 elif config.accept_os:
    2887 2952 
                     if_verbose(1, 'Accepting new output for os "'
    2888 2953 
                                   + config.os + '".')
    2889 
    -                expected_path += '-' + config.os
    2954 
    +                expected_path = Path(str(expected_path) + '-' + config.os)
    2890 2955 
                 else:
    2891 2956 
                     if_verbose(1, 'Accepting new output.')
    2892 2957
    ... ... @@ -3516,7 +3581,7 @@ def find_expected_file(name: TestName, suff: str, way: WayName) -> Path:
    3516 3581
    3517 3582 
         for f in files:
    3518 3583 
             if in_srcdir(f).exists():
    3519 
    -            return f
    3584 
    +            return Path(f)
    3520 3585
    3521 3586 
         return basename
    3522 3587

  • testsuite/driver/testutil.py
    1 1 
     import os
    2 
    +import re
    2 3 
     import subprocess
    3 4 
     import shutil
    4 5 
     import tempfile
    ... ... @@ -179,3 +180,19 @@ def shorten_metric_name(name: str) -> str:
    179 180 
             "binary_size/if_compression(3)": "size/3",
    180 181 
         }
    181 182 
         return dic.get(name, name)
    183 
    +
    184 
    +# I/O manager discovery for a haskell binary. Returns the set of IO Manager
    185 
    +# strings supported by the binary
    186 
    +def discover_io_managers(hs_exe: Union[str, Path], cwd: Union[str, Path]) -> Set[str]:
    187 
    +    rp = subprocess.run(
    188 
    +        [str(hs_exe), '+RTS', '--info', '-RTS'],
    189 
    +        cwd=cwd,
    190 
    +        stdout=subprocess.PIPE,
    191 
    +        stderr=subprocess.DEVNULL)
    192 
    +    stdout = rp.stdout.decode('utf-8', errors='replace')
    193 
    +
    194 
    +    m = re.search(r'\("I/O managers", "(.*)"\)', stdout)
    195 
    +    if not m:
    196 
    +        raise Exception('Expected stdout output of form \'... ("I/O managers", "select selectbis poll") ...\' but got:\n{}'.format(stdout))
    197 
    +
    198 
    +    return set(m.group(1).split())

  • testsuite/tests/annotations/should_run/Makefile
    ... ... @@ -9,3 +9,7 @@ config :
    9 9 
     	echo "module Config where" >>$(CONFIG_HS)
    10 10 
     	echo "cTop          :: String" >> $(CONFIG_HS)
    11 11 
     	echo 'cTop          = "$(subst \,\\,$(shell '$(TEST_HC)' --print-libdir))"' >> $(CONFIG_HS)
    12 
    +
    13 
    +T16841:
    14 
    +	'$(TEST_HC)' $(TEST_HC_OPTS) -v0 -c T16841.hs
    15 
    +	'$(TEST_HC)' $(TEST_HC_OPTS) --show-iface T16841.hi | grep 'annotated by'

  • testsuite/tests/annotations/should_run/T16841.hs
    1 
    +-- | Measures the overhead of serializing annotations of a few types.
    2 
    +module T16841 where
    3 
    +
    4 
    +foo :: Int
    5 
    +foo = 42
    6 
    +
    7 
    +{-# ANN foo (42 :: Int) #-}
    8 
    +{-# ANN foo (2^100 :: Integer) #-}
    9 
    +{-# ANN foo (3.25 :: Double) #-}
    10 
    +{-# ANN foo 'x' #-}
    11 
    +{-# ANN foo "helloworld" #-}
    12 
    +{-# ANN foo (Just True) #-}
    13 
    +{-# ANN foo ([1..100] :: [Int]) #-}
    14 
    +{-# ANN module (Left 7 :: Either Int String) #-}
    15 
    +

  • testsuite/tests/annotations/should_run/T16841.stdout
    1 
    +Module target T16841 annotated by 15 of type Either Int [Char]
    2 
    +Named target foo annotated by 1509 of type [Int]
    3 
    +Named target foo annotated by 18 of type Maybe Bool
    4 
    +Named target foo annotated by 119 of type [Char]
    5 
    +Named target foo annotated by 2 of type Char
    6 
    +Named target foo annotated by 11 of type Double
    7 
    +Named target foo annotated by 24 of type Integer
    8 
    +Named target foo annotated by 6 of type Int
    9 
    +

  • testsuite/tests/annotations/should_run/all.T
    ... ... @@ -16,6 +16,10 @@ test('annrun01',
    16 16 
          multimod_compile_and_run,
    17 17 
          ['annrun01', '-package ghc ' + config.ghc_th_way_flags])
    18 18
    19 
    +# Skipping on windows because of platform-specific failures.  See
    20 
    +# https://gitlab.haskell.org/ghc/ghc/-/merge_requests/16841#note_706770
    21 
    +test('T16841', [req_th, windows_skip, extra_files(['T16841.hs'])], makefile_test, ['T16841'])
    22 
    +
    19 23 
     """"
    20 24 
     Helpful things to C+P:
    21 25

  • testsuite/tests/codeGen/should_gen_asm/T24813.asm
    1 
    +popcnt8:
    2 
    +        movzbl
    3 
    +        popcnt
    4 
    +        movq
    5 
    +        jmp
    6 
    +popcnt16:
    7 
    +        movzwl
    8 
    +        popcnt
    9 
    +        movq
    10 
    +        jmp

  • testsuite/tests/codeGen/should_gen_asm/T24813.cmm
    1 
    +#include "Cmm.h"
    2 
    +
    3 
    +// Popcount of a zero-extended sub-word value should be a single
    4 
    +// zero-extending load followed by one POPCNT (#24813).
    5 
    +
    6 
    +popcnt8 (W_ p) {
    7 
    +    W_ r;
    8 
    +    (r) = prim %popcnt8(%zx64(bits8[p]));
    9 
    +    return (r);
    10 
    +}
    11 
    +
    12 
    +popcnt16 (W_ p) {
    13 
    +    W_ r;
    14 
    +    (r) = prim %popcnt16(%zx64(bits16[p]));
    15 
    +    return (r);
    16 
    +}

  • testsuite/tests/codeGen/should_gen_asm/all.T
    ... ... @@ -27,6 +27,7 @@ test('T25233', [unless(arch('x86_64'), skip),
    27 27 
                     when(unregisterised(), skip)], compile_grep_asm, ['hs', True, '-O'])
    28 28 
     test('T25233b', [unless(arch('x86_64'), skip),
    29 29 
                      when(unregisterised(), skip)], compile_grep_asm, ['cmm', True, ''])
    30 
    +test('T24813', is_amd64_codegen, compile_cmp_asm, ['cmm', '-msse4.2'])
    30 31 
     is_aarch64_codegen = [
    31 32 
         unless(arch('aarch64'), skip),
    32 33 
         when(unregisterised(), skip),

  • testsuite/tests/plugins/T26761Plugin.hs
    ... ... @@ -7,6 +7,7 @@ import GHC
    7 7 
     import GHC.Plugins
    8 8 
     import GHC.Tc.Types
    9 9 
     import GHC.Tc.Utils.Monad
    10 
    +import qualified Data.ByteString.Short as Short
    10 11 
     import qualified Data.Map as Map
    11 12 
     import Data.Word (Word8)
    12 13 
     import System.IO (hFlush, stdout)
    ... ... @@ -38,5 +39,5 @@ plugin = defaultPlugin { typeCheckResultAction = typecheckPlugin }
    38 39 
           -- check that it is visible from other modules.
    39 40 
           let ann = Annotation
    40 41 
                       (ModuleTarget $ tcg_mod gblEnv)
    41 
    -                  (toSerialized id [0])
    42 
    +                  (toSerialized id (Short.pack [0]))
    42 43 
           return gblEnv { tcg_anns = ann : tcg_anns gblEnv }

  • testsuite/tests/plugins/all.T
    ... ... @@ -155,7 +155,7 @@ test('T14335',
    155 155 
            -fexternal-interpreter -package simple-plugin ' + config.plugin_way_flags])
    156 156
    157 157 
     test('T26761', [extra_files(['T26761Plugin.hs', 'T26761a.hs'])],
    158 
    -     multimod_compile, ['T26761', '-package ghc ' + config.plugin_way_flags ])
    158 
    +     multimod_compile, ['T26761', '-package ghc -package bytestring ' + config.plugin_way_flags ])
    159 159
    160 160 
     test('plugin-recomp-pure',
    161 161 
          [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'
    674 674 
     test('T23400', [], compile_and_run, ['-with-rtsopts -A8k'])
    675 675
    676 676 
     test('IOManager', [js_skip, when(arch('wasm32'), skip), when(opsys('mingw32'), skip),
    677 
    -                   pre_cmd('$MAKE -s --no-print-directory IOManager.hs')],
    678 
    -                  compile_and_run, [''])
    677 
    +                   pre_cmd('$MAKE -s --no-print-directory IOManager.hs'),
    678 
    +                   extra_ways(['threaded2']), all_available_io_managers_except('winio')],
    679 
    +                   compile_and_run, [''])
    679 680
    680 681 
     test('T24142', [req_target_smp], compile_and_run, ['-threaded -with-rtsopts "-N2"'])
    681 682

  • utils/check-exact/ExactPrint.hs
    ... ... @@ -1486,9 +1486,7 @@ markAnnList ann action = do
    1486 1486 
     markAnnList' :: (Monad m, Monoid w)
    1487 1487 
       => AnnList -> EP w m a -> EP w m (AnnList, a)
    1488 1488 
     markAnnList' ann action = do
    1489 
    -  markAnnListA' ann $ \a -> do
    1490 
    -    r <- action
    1491 
    -    return (a,r)
    1489 
    +  markAnnListA' ann $ action
    1492 1490
    1493 1491 
     markAnnListA :: (Monad m, Monoid w)
    1494 1492 
       => EpAnn AnnList
    ... ... @@ -1503,14 +1501,14 @@ markAnnListA an action = do
    1503 1501
    1504 1502 
     markAnnListA' :: (Monad m, Monoid w)
    1505 1503 
       => AnnList
    1506 
    -  -> (AnnList -> EP w m (AnnList, a))
    1504 
    +  -> EP w m a
    1507 1505 
       -> EP w m (AnnList, a)
    1508 1506 
     markAnnListA' an action = do
    1509 1507 
       an0 <- markLensBracketsO' an lal_brackets
    1510 1508 
       an1 <- markEpAnnAllLT' an0 lal_semis
    1511 
    -  (an2, r) <- action an1
    1512 
    -  an3 <- markLensBracketsC' an2 lal_brackets
    1513 
    -  return (an3, r)
    1509 
    +  r <- action
    1510 
    +  an2 <- markLensBracketsC' an1 lal_brackets
    1511 
    +  return (an2, r)
    1514 1512
    1515 1513 
     -- ---------------------------------------------------------------------
    1516 1514
    ... ... @@ -2413,9 +2411,7 @@ instance ExactPrint (ClsInstDecl GhcPs) where
    2413 2411 
                          , cid_modifiers = mods })
    2414 2412 
           = do
    2415 2413 
               (mbWarn', i', w', mbOverlap', inst_ty', mods') <- top_matter
    2416 
    -          (ann_list',  decls') <- markAnnListA' ann_list $ \a -> do
    2417 
    -            r <- setLayoutBoth $ mapM markAnnotated decls
    2418 
    -            return (a,r)
    2414 
    +          (ann_list',  decls') <- markAnnListA' ann_list $  setLayoutBoth $ mapM markAnnotated decls
    2419 2415 
               return (ClsInstDecl { cid_ext = (mbWarn', AnnClsInstDecl i' w' ann_list')
    2420 2416 
                                   , cid_poly_ty = inst_ty'
    2421 2417 
                                   , cid_decls = decls'
    ... ... @@ -3336,9 +3332,7 @@ markMaybeDodgyStmts (an,l) stmts =
    3336 3332 
               c' <- markEpToken c
    3337 3333 
               return (Left (o',c'), r)
    3338 3334 
             Right an' -> do
    3339 
    -         (an'',r') <- markAnnListA' an' $ \a -> do
    3340 
    -           r <- markAnnotatedWithLayout stmts
    3341 
    -           return (a, r)
    3335 
    +         (an'',r') <- markAnnListA' an' $ markAnnotatedWithLayout stmts
    3342 3336 
              return (Right an'',r')
    3343 3337 
           return ((an0, l), stmts')
    3344 3338 
         else return ((an, l), stmts)
    ... ... @@ -3411,9 +3405,7 @@ instance (Typeable body,
    3411 3405 
         = MG (origin,an) (L (setAnchorEpa l anc ts cs) matches)
    3412 3406
    3413 3407 
       exact (MG (origin,an) (L l matches)) = do
    3414 
    -    (an0,matches') <- markAnnListA' an $ \a -> do
    3415 
    -        m' <- markAnnotated matches
    3416 
    -        return (a,m')
    3408 
    +    (an0,matches') <- markAnnListA' an $ markAnnotated matches
    3417 3409 
         return (MG (origin, an0) (L l matches'))
    3418 3410
    3419 3411 
     -- ---------------------------------------------------------------------

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/compare/eac8649f07a945988f53425b131ddd4a79cf13de...e3a21c9668a4db6cec6a14fc5c46c6a85a600f37 at 1793240807