Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 4ee303a8 by Ben Gamari at 2025-06-05T10:11:44-04:00 hadrian: Place user options after package arguments This makes it easier for the user to override the default package arguments with `UserSettings.hs`. Fixes #25821. - - - - - 1c1332bc by Ryan Hendrickson at 2025-06-05T10:11:48-04:00 haddock: Parse math even after ordinary characters Fixes a bug where math sections were not recognized if preceded by a character that isn't special (like space or a markup character). - - - - - 3c14eb83 by ARATA Mizuki at 2025-06-05T10:11:53-04:00 AArch64 NCG: Fix sub-word arithmetic right shift As noted in Note [Signed arithmetic on AArch64], we should zero-extend sub-word values. Fixes #26061 - - - - - b07b3b3f by Simon Hengel at 2025-06-05T10:11:56-04:00 Allow Unicode in "message" and "hints" with -fdiagnostics-as-json (fixes #26075) - - - - - 06314b7c by ARATA Mizuki at 2025-06-05T10:11:59-04:00 x86 NCG: Fix code generation of bswap64 on i386 Co-authored-by: sheaf Fix #25601 - - - - - 15 changed files: - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/Types/Error.hs - hadrian/src/Settings.hs - + testsuite/tests/cmm/should_run/T25601.hs - + testsuite/tests/cmm/should_run/T25601.stdout - + testsuite/tests/cmm/should_run/T25601a.cmm - testsuite/tests/cmm/should_run/all.T - + testsuite/tests/codeGen/should_run/T26061.hs - + testsuite/tests/codeGen/should_run/T26061.stdout - testsuite/tests/codeGen/should_run/all.T - testsuite/tests/driver/json.stderr - testsuite/tests/driver/json_warn.stderr - utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs - utils/haddock/haddock-library/test/Documentation/Haddock/ParserSpec.hs Changes: ===================================== compiler/GHC/CmmToAsm/AArch64/CodeGen.hs ===================================== @@ -928,21 +928,25 @@ getRegister' config plat expr CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do (reg_x, _format_x, code_x) <- getSomeReg x - 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))))) + 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)))) + `snocOL` (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] CmmMachOp (MO_S_Shr w) [x, y] | w == W8 -> do (reg_x, _format_x, code_x) <- getSomeReg x (reg_y, _format_y, code_y) <- getSomeReg y return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL` - (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) + (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) `snocOL` + (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do (reg_x, _format_x, code_x) <- getSomeReg x - 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))))) + 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)))) + `snocOL` (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] CmmMachOp (MO_S_Shr w) [x, y] | w == W16 -> do (reg_x, _format_x, code_x) <- getSomeReg x (reg_y, _format_y, code_y) <- getSomeReg y return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL` - (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) + (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) `snocOL` + (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W32 || w == W64 ===================================== compiler/GHC/CmmToAsm/X86/CodeGen.hs ===================================== @@ -6067,10 +6067,23 @@ genByteSwap width dst src = do W64 | is32Bit -> do let Reg64 dst_hi dst_lo = localReg64 dst RegCode64 vcode rhi rlo <- iselExpr64 src - return $ vcode `appOL` - toOL [ MOV II32 (OpReg rlo) (OpReg dst_hi), - MOV II32 (OpReg rhi) (OpReg dst_lo), - BSWAP II32 dst_hi, + tmp <- getNewRegNat II32 + -- Swap the low and high halves of the register. + -- + -- NB: if dst_hi == rhi, we must make sure to preserve the contents + -- of rhi before writing to dst_hi (#25601). + let shuffle = if dst_hi == rhi && dst_lo == rlo then + toOL [ MOV II32 (OpReg rhi) (OpReg tmp), + MOV II32 (OpReg rlo) (OpReg dst_hi), + MOV II32 (OpReg tmp) (OpReg dst_lo) ] + else if dst_hi == rhi then + toOL [ MOV II32 (OpReg rhi) (OpReg dst_lo), + MOV II32 (OpReg rlo) (OpReg dst_hi) ] + else + toOL [ MOV II32 (OpReg rlo) (OpReg dst_hi), + MOV II32 (OpReg rhi) (OpReg dst_lo) ] + return $ vcode `appOL` shuffle `appOL` + toOL [ BSWAP II32 dst_hi, BSWAP II32 dst_lo ] W16 -> do let dst_r = getLocalRegReg dst ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -602,8 +602,14 @@ instance Diagnostic e => ToJson (MsgEnvelope e) where where diag = errMsgDiagnostic m opts = defaultDiagnosticOpts @e - style = mkErrStyle (errMsgContext m) - ctx = defaultSDocContext {sdocStyle = style } + ctx = defaultSDocContext { + sdocStyle = mkErrStyle (errMsgContext m) + , sdocCanUseUnicode = True + -- Using Unicode makes it easier to consume the JSON output, + -- e.g. a suggestion to use foldl' will be displayed as + -- \u2018foldl'\u2019, which is not easily confused with + -- the quoted ‘foldl’ (note: no tick). + } diagMsg = filter (not . isEmpty ctx) (unDecorated (diagnosticMessage (opts) diag)) renderToJSString :: SDoc -> JsonDoc renderToJSString = JSString . (renderWithContext ctx) ===================================== hadrian/src/Settings.hs ===================================== @@ -35,7 +35,7 @@ getExtraArgs :: Args getExtraArgs = expr flavour >>= extraArgs getArgs :: Args -getArgs = mconcat [ defaultBuilderArgs, getExtraArgs, defaultPackageArgs ] +getArgs = mconcat [ defaultBuilderArgs, defaultPackageArgs, getExtraArgs ] getLibraryWays :: Ways getLibraryWays = expr flavour >>= libraryWays ===================================== testsuite/tests/cmm/should_run/T25601.hs ===================================== @@ -0,0 +1,22 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE UnliftedFFITypes #-} + +import Numeric +import GHC.Prim +import GHC.Word +import GHC.IO +import GHC.Ptr +import Data.List +import qualified Data.ByteString as BS + +foreign import prim "test" c_test :: Addr# -> State# RealWorld -> (# State# RealWorld, Word64# #) + +main :: IO () +main = do + let bs = BS.pack $ take 100000 [ fromIntegral i | i <- [(1 :: Int) ..] ] + n <- BS.useAsCString bs $ \(Ptr addr) -> IO $ \s -> + case c_test addr s of (# s', n #) -> (# s', W64# n #) + print $ showHex n "" ===================================== testsuite/tests/cmm/should_run/T25601.stdout ===================================== @@ -0,0 +1 @@ +"f3f1ffffffffffff" ===================================== testsuite/tests/cmm/should_run/T25601a.cmm ===================================== @@ -0,0 +1,7 @@ +#include "Cmm.h" + +test ( W_ buffer ) { + bits64 ret; + (ret) = prim %bswap64(%neg(%zx64(bits16[buffer + (12 :: W_)]))); + return (ret); +} ===================================== testsuite/tests/cmm/should_run/all.T ===================================== @@ -47,3 +47,8 @@ test('AtomicFetch', ], multi_compile_and_run, ['AtomicFetch', [('AtomicFetch_cmm.cmm', '')], '']) + +test('T25601', + [req_cmm], + multi_compile_and_run, + ['T25601', [('T25601a.cmm', '')], '']) ===================================== testsuite/tests/codeGen/should_run/T26061.hs ===================================== @@ -0,0 +1,41 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ExtendedLiterals #-} +import GHC.Word +import GHC.Exts + +f :: Int16# -> Word16# +f x = let !w = int16ToWord16# (x `uncheckedShiftRAInt16#` 1#) + in w `remWord16#` 13#Word16 +{-# NOINLINE f #-} + +g :: Int8# -> Word8# +g x = let !w = int8ToWord8# (x `uncheckedShiftRAInt8#` 1#) + in w `remWord8#` 19#Word8 +{-# NOINLINE g #-} + +h :: Int16# -> Int# -> Word16# +h x y = let !w = int16ToWord16# (x `uncheckedShiftRAInt16#` y) + in w `remWord16#` 13#Word16 +{-# NOINLINE h #-} + +i :: Int8# -> Int# -> Word8# +i x y = let !w = int8ToWord8# (x `uncheckedShiftRAInt8#` y) + in w `remWord8#` 19#Word8 +{-# NOINLINE i #-} + +main :: IO () +main = do + print (W16# (f (-100#Int16))) + print (W8# (g (-100#Int8))) + print (W16# (h (-100#Int16) 1#)) + print (W8# (i (-100#Int8) 1#)) + +-- int16ToWord16 (-100 `shiftR` 1) `rem` 13 +-- = int16ToWord16 (-50) `rem` 13 +-- = 65486 `rem` 13 +-- = 5 + +-- int8ToWord8 (-100 `shiftR` 1) `rem` 19 +-- = int8ToWord8 (-50) `rem` 19 +-- = 206 `rem` 19 +-- = 16 ===================================== testsuite/tests/codeGen/should_run/T26061.stdout ===================================== @@ -0,0 +1,4 @@ +5 +16 +5 +16 ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -255,3 +255,4 @@ test('T24893', normal, compile_and_run, ['-O']) test('CCallConv', [req_c], compile_and_run, ['CCallConv_c.c']) test('T25364', normal, compile_and_run, ['']) +test('T26061', normal, compile_and_run, ['']) ===================================== testsuite/tests/driver/json.stderr ===================================== @@ -1 +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"]} +{"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,2 +1,2 @@ -{"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"]}} -{"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"}} +{"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"]}} +{"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,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} @@ -28,6 +29,7 @@ import Control.Applicative import Control.Arrow (first) import Control.Monad import Data.Char (chr, isAlpha, isSpace, isUpper) +import Data.Functor (($>)) import Data.List (elemIndex, intercalate, intersperse, unfoldr) import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid @@ -186,11 +188,29 @@ specialChar = "_/<@\"&'`#[ " -- to ensure that we have already given a chance to more meaningful parsers -- before capturing their characters. string' :: Parser (DocH mod a) -string' = DocString . unescape . T.unpack <$> takeWhile1_ (`notElem` specialChar) +string' = + DocString + <$> ((:) <$> rawOrEscChar "" <*> many (rawOrEscChar "([")) + -- After the first character, stop for @\(@ or @\[@ math starters. (The + -- first character won't start a valid math string because this parser + -- should follow math parsers. But this parser is expected to accept at + -- least one character from all inputs that don't start with special + -- characters, so the first character parser can't have the @"(["@ + -- restriction.) where - unescape "" = "" - unescape ('\\' : x : xs) = x : unescape xs - unescape (x : xs) = x : unescape xs + -- | Parse a single logical character, either raw or escaped. Don't accept + -- escaped characters from the argument string. + rawOrEscChar :: [Char] -> Parser Char + rawOrEscChar restrictedEscapes = try $ Parsec.noneOf specialChar >>= \case + -- Handle backslashes: + -- - Fail on forbidden escape characters. + -- - Non-forbidden characters: simply unescape, e.g. parse "\b" as 'b', + -- - Trailing backslash: treat it as a raw backslash, not an escape + -- sequence. (This is the logic that this parser followed when this + -- comment was written; it is not necessarily intentional but now I + -- don't want to break anything relying on it.) + '\\' -> Parsec.noneOf restrictedEscapes <|> Parsec.eof $> '\\' + c -> pure c -- | Skips a single special character and treats it as a plain string. -- 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 it "supports title for deprecated picture syntax" $ do "<<b a z>>" `shouldParseTo` image "b" "a z" + context "when parsing inline math" $ do + it "accepts inline math immediately after punctuation" $ do + "(\\(1 + 2 = 3\\) is an example of addition)" + `shouldParseTo` "(" + <> DocMathInline "1 + 2 = 3" + <> " is an example of addition)" + context "when parsing display math" $ do it "accepts markdown syntax for display math containing newlines" $ do "\\[\\pi\n\\pi\\]" `shouldParseTo` DocMathDisplay "\\pi\n\\pi" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4de53bb43a0b92fcade65847d0841b9... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4de53bb43a0b92fcade65847d0841b9... You're receiving this email because of your account on gitlab.haskell.org.