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

Commits:

14 changed files:

Changes:

  • compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
    ... ... @@ -928,21 +928,25 @@ getRegister' config plat expr
    928 928
    929 929 
         CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do
    930 930 
           (reg_x, _format_x, code_x) <- getSomeReg x
    931 
    -      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n)))))
    931 
    +      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n))))
    932 
    +                                                 `snocOL` (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]
    932 933 
         CmmMachOp (MO_S_Shr w) [x, y] | w == W8 -> do
    933 934 
           (reg_x, _format_x, code_x) <- getSomeReg x
    934 935 
           (reg_y, _format_y, code_y) <- getSomeReg y
    935 936 
           return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL`
    936 
    -                                                                         (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))
    937 
    +                                                                         (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) `snocOL`
    938 
    +                                                                         (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]
    937 939
    938 940 
         CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do
    939 941 
           (reg_x, _format_x, code_x) <- getSomeReg x
    940 
    -      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n)))))
    942 
    +      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n))))
    943 
    +                                                 `snocOL` (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]
    941 944 
         CmmMachOp (MO_S_Shr w) [x, y] | w == W16 -> do
    942 945 
           (reg_x, _format_x, code_x) <- getSomeReg x
    943 946 
           (reg_y, _format_y, code_y) <- getSomeReg y
    944 947 
           return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL`
    945 
    -                                                                         (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))
    948 
    +                                                                         (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) `snocOL`
    949 
    +                                                                         (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]
    946 950
    947 951 
         CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))]
    948 952 
           | w == W32 || w == W64

  • compiler/GHC/CmmToAsm/X86/CodeGen.hs
    ... ... @@ -6067,10 +6067,23 @@ genByteSwap width dst src = do
    6067 6067 
           W64 | is32Bit -> do
    6068 6068 
             let Reg64 dst_hi dst_lo = localReg64 dst
    6069 6069 
             RegCode64 vcode rhi rlo <- iselExpr64 src
    6070 
    -        return $ vcode `appOL`
    6071 
    -                 toOL [ MOV II32 (OpReg rlo) (OpReg dst_hi),
    6072 
    -                        MOV II32 (OpReg rhi) (OpReg dst_lo),
    6073 
    -                        BSWAP II32 dst_hi,
    6070 
    +        tmp <- getNewRegNat II32
    6071 
    +        -- Swap the low and high halves of the register.
    6072 
    +        --
    6073 
    +        -- NB: if dst_hi == rhi, we must make sure to preserve the contents
    6074 
    +        -- of rhi before writing to dst_hi (#25601).
    6075 
    +        let shuffle = if dst_hi == rhi && dst_lo == rlo then
    6076 
    +                        toOL [ MOV II32 (OpReg rhi) (OpReg tmp),
    6077 
    +                               MOV II32 (OpReg rlo) (OpReg dst_hi),
    6078 
    +                               MOV II32 (OpReg tmp) (OpReg dst_lo) ]
    6079 
    +                      else if dst_hi == rhi then
    6080 
    +                        toOL [ MOV II32 (OpReg rhi) (OpReg dst_lo),
    6081 
    +                               MOV II32 (OpReg rlo) (OpReg dst_hi) ]
    6082 
    +                      else
    6083 
    +                        toOL [ MOV II32 (OpReg rlo) (OpReg dst_hi),
    6084 
    +                               MOV II32 (OpReg rhi) (OpReg dst_lo) ]
    6085 
    +        return $ vcode `appOL` shuffle `appOL`
    6086 
    +                 toOL [ BSWAP II32 dst_hi,
    6074 6087 
                             BSWAP II32 dst_lo ]
    6075 6088 
           W16 -> do
    6076 6089 
             let dst_r = getLocalRegReg dst

  • compiler/GHC/Types/Error.hs
    ... ... @@ -602,8 +602,14 @@ instance Diagnostic e => ToJson (MsgEnvelope e) where
    602 602 
         where
    603 603 
           diag = errMsgDiagnostic m
    604 604 
           opts = defaultDiagnosticOpts @e
    605 
    -      style = mkErrStyle (errMsgContext m)
    606 
    -      ctx = defaultSDocContext {sdocStyle = style }
    605 
    +      ctx = defaultSDocContext {
    606 
    +          sdocStyle = mkErrStyle (errMsgContext m)
    607 
    +        , sdocCanUseUnicode = True
    608 
    +             -- Using Unicode makes it easier to consume the JSON output,
    609 
    +             -- e.g. a suggestion to use foldl' will be displayed as
    610 
    +             -- \u2018foldl'\u2019, which is not easily confused with
    611 
    +             -- the quoted ‘foldl’ (note: no tick).
    612 
    +        }
    607 613 
           diagMsg = filter (not . isEmpty ctx) (unDecorated (diagnosticMessage (opts) diag))
    608 614 
           renderToJSString :: SDoc -> JsonDoc
    609 615 
           renderToJSString = JSString . (renderWithContext ctx)

  • testsuite/tests/cmm/should_run/T25601.hs
    1 
    +{-# LANGUAGE UnboxedTuples #-}
    2 
    +{-# LANGUAGE MagicHash #-}
    3 
    +{-# LANGUAGE ForeignFunctionInterface #-}
    4 
    +{-# LANGUAGE GHCForeignImportPrim #-}
    5 
    +{-# LANGUAGE UnliftedFFITypes #-}
    6 
    +
    7 
    +import Numeric
    8 
    +import GHC.Prim
    9 
    +import GHC.Word
    10 
    +import GHC.IO
    11 
    +import GHC.Ptr
    12 
    +import Data.List
    13 
    +import qualified Data.ByteString as BS
    14 
    +
    15 
    +foreign import prim "test" c_test :: Addr# -> State# RealWorld -> (# State# RealWorld, Word64# #)
    16 
    +
    17 
    +main :: IO ()
    18 
    +main = do
    19 
    +    let bs = BS.pack $ take 100000 [ fromIntegral i | i <- [(1 :: Int) ..] ]
    20 
    +    n <- BS.useAsCString bs $ \(Ptr addr) -> IO $ \s ->
    21 
    +      case c_test addr s of (# s', n #) -> (# s', W64# n #)
    22 
    +    print $ showHex n ""

  • testsuite/tests/cmm/should_run/T25601.stdout
    1 
    +"f3f1ffffffffffff"

  • testsuite/tests/cmm/should_run/T25601a.cmm
    1 
    +#include "Cmm.h"
    2 
    +
    3 
    +test ( W_ buffer ) {
    4 
    +  bits64 ret;
    5 
    +  (ret) = prim %bswap64(%neg(%zx64(bits16[buffer + (12 :: W_)])));
    6 
    +  return (ret);
    7 
    +}

  • testsuite/tests/cmm/should_run/all.T
    ... ... @@ -47,3 +47,8 @@ test('AtomicFetch',
    47 47 
          ],
    48 48 
          multi_compile_and_run,
    49 49 
          ['AtomicFetch', [('AtomicFetch_cmm.cmm', '')], ''])
    50 
    +
    51 
    +test('T25601',
    52 
    +     [req_cmm],
    53 
    +     multi_compile_and_run,
    54 
    +     ['T25601', [('T25601a.cmm', '')], ''])

  • testsuite/tests/codeGen/should_run/T26061.hs
    1 
    +{-# LANGUAGE MagicHash #-}
    2 
    +{-# LANGUAGE ExtendedLiterals #-}
    3 
    +import GHC.Word
    4 
    +import GHC.Exts
    5 
    +
    6 
    +f :: Int16# -> Word16#
    7 
    +f x = let !w = int16ToWord16# (x `uncheckedShiftRAInt16#` 1#)
    8 
    +      in w `remWord16#` 13#Word16
    9 
    +{-# NOINLINE f #-}
    10 
    +
    11 
    +g :: Int8# -> Word8#
    12 
    +g x = let !w = int8ToWord8# (x `uncheckedShiftRAInt8#` 1#)
    13 
    +      in w `remWord8#` 19#Word8
    14 
    +{-# NOINLINE g #-}
    15 
    +
    16 
    +h :: Int16# -> Int# -> Word16#
    17 
    +h x y = let !w = int16ToWord16# (x `uncheckedShiftRAInt16#` y)
    18 
    +      in w `remWord16#` 13#Word16
    19 
    +{-# NOINLINE h #-}
    20 
    +
    21 
    +i :: Int8# -> Int# -> Word8#
    22 
    +i x y = let !w = int8ToWord8# (x `uncheckedShiftRAInt8#` y)
    23 
    +        in w `remWord8#` 19#Word8
    24 
    +{-# NOINLINE i #-}
    25 
    +
    26 
    +main :: IO ()
    27 
    +main = do
    28 
    +  print (W16# (f (-100#Int16)))
    29 
    +  print (W8# (g (-100#Int8)))
    30 
    +  print (W16# (h (-100#Int16) 1#))
    31 
    +  print (W8# (i (-100#Int8) 1#))
    32 
    +
    33 
    +-- int16ToWord16 (-100 `shiftR` 1) `rem` 13
    34 
    +--   = int16ToWord16 (-50) `rem` 13
    35 
    +--   = 65486 `rem` 13
    36 
    +--   = 5
    37 
    +
    38 
    +-- int8ToWord8 (-100 `shiftR` 1) `rem` 19
    39 
    +--   = int8ToWord8 (-50) `rem` 19
    40 
    +--   = 206 `rem` 19
    41 
    +--   = 16

  • testsuite/tests/codeGen/should_run/T26061.stdout
    1 
    +5
    2 
    +16
    3 
    +5
    4 
    +16

  • testsuite/tests/codeGen/should_run/all.T
    ... ... @@ -255,3 +255,4 @@ test('T24893', normal, compile_and_run, ['-O'])
    255 255
    256 256 
     test('CCallConv', [req_c], compile_and_run, ['CCallConv_c.c'])
    257 257 
     test('T25364', normal, compile_and_run, [''])
    258 
    +test('T26061', normal, compile_and_run, [''])

  • testsuite/tests/driver/json.stderr
    1 
    -{"version":"1.1","ghcVersion":"ghc-9.13.20241113","span":{"file":"json.hs","start":{"line":9,"column":11},"end":{"line":9,"column":21}},"severity":"Error","code":48010,"message":["Empty list of alternatives in case expression"],"hints":["Perhaps you intended to use the `EmptyCase' extension"]}
    1 
    +{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json.hs","start":{"line":9,"column":11},"end":{"line":9,"column":21}},"severity":"Error","code":48010,"message":["Empty list of alternatives in case expression"],"hints":["Perhaps you intended to use the \u2018EmptyCase\u2019 extension"]}

  • testsuite/tests/driver/json_warn.stderr
    1 
    -{"version":"1.1","ghcVersion":"ghc-9.13.20241113","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: `x'"],"hints":[],"reason":{"flags":["unused-matches"]}}
    2 
    -{"version":"1.1","ghcVersion":"ghc-9.13.20241113","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"message":["In the use of `head'\n(imported from Prelude, but defined in GHC.Internal.List):\n\"This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use \"Data.List.NonEmpty\".\""],"hints":[],"reason":{"category":"x-partial"}}
    1 
    +{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}}
    2 
    +{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"message":["In the use of \u2018head\u2019\n(imported from Prelude, but defined in GHC.Internal.List):\n\"This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use \"Data.List.NonEmpty\".\""],"hints":[],"reason":{"category":"x-partial"}}

  • utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
    1 
    +{-# LANGUAGE LambdaCase #-}
    1 2 
     {-# LANGUAGE OverloadedStrings #-}
    2 3 
     {-# LANGUAGE ViewPatterns #-}
    3 4
    ... ... @@ -28,6 +29,7 @@ import Control.Applicative
    28 29 
     import Control.Arrow (first)
    29 30 
     import Control.Monad
    30 31 
     import Data.Char (chr, isAlpha, isSpace, isUpper)
    32 
    +import Data.Functor (($>))
    31 33 
     import Data.List (elemIndex, intercalate, intersperse, unfoldr)
    32 34 
     import Data.Maybe (fromMaybe, mapMaybe)
    33 35 
     import Data.Monoid
    ... ... @@ -186,11 +188,29 @@ specialChar = "_/<@\"&'`#[ "
    186 188 
     -- to ensure that we have already given a chance to more meaningful parsers
    187 189 
     -- before capturing their characters.
    188 190 
     string' :: Parser (DocH mod a)
    189 
    -string' = DocString . unescape . T.unpack <$> takeWhile1_ (`notElem` specialChar)
    191 
    +string' =
    192 
    +  DocString
    193 
    +    <$> ((:) <$> rawOrEscChar "" <*> many (rawOrEscChar "(["))
    194 
    +    -- After the first character, stop for @\(@ or @\[@ math starters. (The
    195 
    +    -- first character won't start a valid math string because this parser
    196 
    +    -- should follow math parsers. But this parser is expected to accept at
    197 
    +    -- least one character from all inputs that don't start with special
    198 
    +    -- characters, so the first character parser can't have the @"(["@
    199 
    +    -- restriction.)
    190 200 
       where
    191 
    -    unescape "" = ""
    192 
    -    unescape ('\\' : x : xs) = x : unescape xs
    193 
    -    unescape (x : xs) = x : unescape xs
    201 
    +    -- | Parse a single logical character, either raw or escaped. Don't accept
    202 
    +    -- escaped characters from the argument string.
    203 
    +    rawOrEscChar :: [Char] -> Parser Char
    204 
    +    rawOrEscChar restrictedEscapes = try $ Parsec.noneOf specialChar >>= \case
    205 
    +      -- Handle backslashes:
    206 
    +      --   - Fail on forbidden escape characters.
    207 
    +      --   - Non-forbidden characters: simply unescape, e.g. parse "\b" as 'b',
    208 
    +      --   - Trailing backslash: treat it as a raw backslash, not an escape
    209 
    +      --     sequence. (This is the logic that this parser followed when this
    210 
    +      --     comment was written; it is not necessarily intentional but now I
    211 
    +      --     don't want to break anything relying on it.)
    212 
    +      '\\' -> Parsec.noneOf restrictedEscapes <|> Parsec.eof $> '\\'
    213 
    +      c -> pure c
    194 214
    195 215 
     -- | Skips a single special character and treats it as a plain string.
    196 216 
     -- This is done to skip over any special characters belonging to other

  • utils/haddock/haddock-library/test/Documentation/Haddock/ParserSpec.hs
    ... ... @@ -284,6 +284,13 @@ spec = do
    284 284 
           it "supports title for deprecated picture syntax" $ do
    285 285 
             "<<b a z>>" `shouldParseTo` image "b" "a z"
    286 286
    287 
    +    context "when parsing inline math" $ do
    288 
    +      it "accepts inline math immediately after punctuation" $ do
    289 
    +        "(\\(1 + 2 = 3\\) is an example of addition)"
    290 
    +          `shouldParseTo` "("
    291 
    +          <> DocMathInline "1 + 2 = 3"
    292 
    +          <> " is an example of addition)"
    293 
    +
    287 294 
         context "when parsing display math" $ do
    288 295 
           it "accepts markdown syntax for display math containing newlines" $ do
    289 296 
             "\\[\\pi\n\\pi\\]" `shouldParseTo` DocMathDisplay "\\pi\n\\pi"

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help