[Git][ghc/ghc][wip/T18570] Calculate multiplicity for record selector functions
by Sjoerd Visscher (＠trac-sjoerd_visscher) 06 Jun '25
by Sjoerd Visscher (＠trac-sjoerd_visscher) 06 Jun '25
06 Jun '25
Sjoerd Visscher pushed to branch wip/T18570 at Glasgow Haskell Compiler / GHC
Commits:
b087fcc4 by Sjoerd Visscher at 2025-06-06T16:53:30+02:00
Calculate multiplicity for record selector functions
Until now record selector functions always had multiplicity Many, but when all the other fields have been declared with multiplicity Many (including the case when there are no other fields), then the selector function is allowed to be used linearly too, as it is allowed to discard all the other fields. Since in that case the multiplicity can be both One and Many, the selector function is made multiplicity-polymorphic.
- - - - -
10 changed files:
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- docs/users_guide/9.14.1-notes.rst
- docs/users_guide/exts/linear_types.rst
- + testsuite/tests/linear/should_compile/LinearRecordSelector.hs
- testsuite/tests/linear/should_compile/all.T
- + testsuite/tests/linear/should_fail/LinearRecordSelectorFail.hs
- + testsuite/tests/linear/should_fail/LinearRecordSelectorFail.stderr
- testsuite/tests/linear/should_fail/all.T
Changes:
=====================================
compiler/GHC/Core/DataCon.hs
=====================================
@@ -44,6 +44,7 @@ module GHC.Core.DataCon (
dataConInstOrigArgTys, dataConRepArgTys, dataConResRepTyArgs,
dataConInstUnivs,
dataConFieldLabels, dataConFieldType, dataConFieldType_maybe,
+ dataConOtherFieldsAllMultMany,
dataConSrcBangs,
dataConSourceArity, dataConRepArity,
dataConIsInfix,
@@ -1405,6 +1406,15 @@ dataConFieldType_maybe :: DataCon -> FieldLabelString
dataConFieldType_maybe con label
= find ((== label) . flLabel . fst) (dcFields con `zip` (scaledThing <$> dcOrigArgTys con))
+-- | Check if all the fields of the 'DataCon' have multiplicity 'Many',
+-- except for the given labelled field. In this case the selector
+-- of the given field can be a linear function, since it is allowed
+-- to discard all the other fields.
+dataConOtherFieldsAllMultMany :: DataCon -> FieldLabelString -> Bool
+dataConOtherFieldsAllMultMany con label
+ = all (\(fld, mult) -> flLabel fld == label || isManyTy mult)
+ (dcFields con `zip` (scaledMult <$> dcOrigArgTys con))
+
-- | Strictness/unpack annotations, from user; or, for imported
-- DataCons, from the interface file
-- The list is in one-to-one correspondence with the arity of the 'DataCon'
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -841,7 +841,7 @@ mkPatSynRecSelBinds :: PatSyn
-> FieldSelectors
-> [(Id, LHsBind GhcRn)]
mkPatSynRecSelBinds ps fields has_sel
- = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl has_sel
+ = [ mkOneRecordSelector False [PatSynCon ps] (RecSelPatSyn ps) fld_lbl has_sel
| fld_lbl <- fields ]
isUnidirectional :: HsPatSynDir a -> Bool
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -32,7 +32,7 @@ import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Bind( tcValBinds )
import GHC.Tc.Utils.TcType
-import GHC.Builtin.Types( unitTy )
+import GHC.Builtin.Types( unitTy, manyDataConTy, multiplicityTy )
import GHC.Builtin.Uniques ( mkBuiltinUnique )
import GHC.Hs
@@ -71,6 +71,7 @@ import GHC.Types.Name.Env
import GHC.Types.Name.Reader ( mkRdrUnqual )
import GHC.Types.Id
import GHC.Types.Id.Info
+import GHC.Types.Var (mkTyVar)
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Unique.Set
@@ -765,7 +766,8 @@ addTyConsToGblEnv tyclss
do { traceTc "tcAddTyCons" $ vcat
[ text "tycons" <+> ppr tyclss
, text "implicits" <+> ppr implicit_things ]
- ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss)
+ ; linearEnabled <- xoptM LangExt.LinearTypes
+ ; gbl_env <- tcRecSelBinds (mkRecSelBinds linearEnabled tyclss)
; th_bndrs <- tcTyThBinders implicit_things
; return (gbl_env, th_bndrs)
}
@@ -848,24 +850,24 @@ tcRecSelBinds sel_bind_prs
, let loc = getSrcSpan sel_id ]
binds = [(NonRecursive, [bind]) | (_, bind) <- sel_bind_prs]
-mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)]
+mkRecSelBinds :: Bool -> [TyCon] -> [(Id, LHsBind GhcRn)]
-- NB We produce *un-typechecked* bindings, rather like 'deriving'
-- This makes life easier, because the later type checking will add
-- all necessary type abstractions and applications
-mkRecSelBinds tycons
- = map mkRecSelBind [ (tc,fld) | tc <- tycons
- , fld <- tyConFieldLabels tc ]
+mkRecSelBinds allowMultiplicity tycons
+ = [ mkRecSelBind allowMultiplicity tc fld | tc <- tycons
+ , fld <- tyConFieldLabels tc ]
-mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn)
-mkRecSelBind (tycon, fl)
- = mkOneRecordSelector all_cons (RecSelData tycon) fl
+mkRecSelBind :: Bool -> TyCon -> FieldLabel -> (Id, LHsBind GhcRn)
+mkRecSelBind allowMultiplicity tycon fl
+ = mkOneRecordSelector allowMultiplicity all_cons (RecSelData tycon) fl
FieldSelectors -- See Note [NoFieldSelectors and naughty record selectors]
where
all_cons = map RealDataCon (tyConDataCons tycon)
-mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> FieldSelectors
+mkOneRecordSelector :: Bool -> [ConLike] -> RecSelParent -> FieldLabel -> FieldSelectors
-> (Id, LHsBind GhcRn)
-mkOneRecordSelector all_cons idDetails fl has_sel
+mkOneRecordSelector allowMultiplicity all_cons idDetails fl has_sel
= (sel_id, L (noAnnSrcSpan loc) sel_bind)
where
loc = getSrcSpan sel_name
@@ -916,17 +918,24 @@ mkOneRecordSelector all_cons idDetails fl has_sel
-- thus suppressing making a binding
-- A slight hack!
+ all_other_fields_unrestricted = all all_other_unrestricted all_cons
+ where
+ all_other_unrestricted PatSynCon{} = False
+ all_other_unrestricted (RealDataCon dc) = dataConOtherFieldsAllMultMany dc lbl
+
sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors]
- | otherwise = mkForAllTys (tyVarSpecToBinders sel_tvbs) $
+ | otherwise = mkForAllTys (tyVarSpecToBinders (sel_tvbs ++ mult_tvb)) $
-- Urgh! See Note [The stupid context] in GHC.Core.DataCon
- mkPhiTy (conLikeStupidTheta con1) $
+ mkPhiTy (conLikeStupidTheta con1) $
-- req_theta is empty for normal DataCon
- mkPhiTy req_theta $
- mkVisFunTyMany data_ty $
- -- Record selectors are always typed with Many. We
- -- could improve on it in the case where all the
- -- fields in all the constructor have multiplicity Many.
+ mkPhiTy req_theta $
+ mkVisFunTy sel_mult data_ty $
field_ty
+ non_partial = length all_cons == length cons_w_field -- See Note [Multiplicity and partial selectors]
+ (mult_tvb, sel_mult) = if allowMultiplicity && non_partial && all_other_fields_unrestricted
+ then ([mkForAllTyBinder InferredSpec mult_var], mkTyVarTy mult_var)
+ else ([], manyDataConTy)
+ mult_var = mkTyVar (mkSysTvName (mkBuiltinUnique 1) (fsLit "m")) multiplicityTy
-- make the binding: sel (C2 { fld = x }) = x
-- sel (C7 { fld = x }) = x
@@ -1165,4 +1174,13 @@ Therefore, when used in the right-hand side of `unT`, GHC attempts to
instantiate `a` with `(forall b. b -> b) -> Int`, which is impredicative.
To make sure that GHC is OK with this, we enable ImpredicativeTypes internally
when typechecking these HsBinds so that the user does not have to.
+
+Note [Multiplicity and partial selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+While all logic for making record selectors multiplicity-polymorphic also applies
+to partial selectors, there is a technical difficulty: the catch-all default case
+that is added throws away its argument, and so cannot be linear. A simple workaround
+was not found. There may exist a more complicated workaround, but the combination of
+linear types and partial selectors is not expected to be very popular in practice, so
+it was decided to not allow multiplicity-polymorphic partial selectors at all.
-}
=====================================
docs/users_guide/9.14.1-notes.rst
=====================================
@@ -67,6 +67,13 @@ Language
This causes the constructor to have type ``Rec :: Int %'Many -> Char %1 -> Record``.
+ Also record selector functions are now multiplicity-polymorphic when possible.
+ In the above example the selector function ``y`` now has type
+ ``y :: Record %m -> Char``, because the ``x`` field is allowed to be discarded.
+ In particular this always applies to the selector of a newtype wrapper.
+ (Note that in theory this should also work with partial record selectors,
+ but for technical reasons this is not supported.)
+
* The :extension:`MonadComprehensions` extension now implies :extension:`ParallelListComp` as was originally intended (see `Monad Comprehensions <https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/monad_comprehension…>`_).
Compiler
=====================================
docs/users_guide/exts/linear_types.rst
=====================================
@@ -238,7 +238,7 @@ to use ``MkT1`` in higher order functions. The additional multiplicity
argument ``m`` is marked as inferred (see
:ref:`inferred-vs-specified`), so that there is no conflict with
visible type application. When displaying types, unless
-``-XLinearTypes`` is enabled, multiplicity polymorphic functions are
+``-XLinearTypes`` is enabled, multiplicity-polymorphic functions are
printed as regular functions (see :ref:`printing-linear-types`);
therefore constructors appear to have regular function types.
@@ -256,21 +256,33 @@ using GADT syntax or record syntax. Given
::
data T2 a b c where
- MkT2 :: a -> b %1 -> c %1 -> T2 a b c -- Note unrestricted arrow in the first argument
+ MkT2 :: a -> b %1 -> c -> T2 a b c -- Note unrestricted arrow in the first argument
-the value ``MkT2 x y z`` can be constructed only if ``x`` is
-unrestricted. On the other hand, a linear function which is matching
-on ``MkT2 x y z`` must consume ``y`` and ``z`` exactly once, but there
-is no restriction on ``x``. The same example can be written using record syntax:
+the value ``MkT2 x y z`` can be constructed only if ``x`` and
+``z`` are unrestricted. On the other hand, a linear function which is
+matching on ``MkT2 x y z`` must consume ``y`` exactly once, but there
+is no restriction on ``x`` and ``z``.
+The same example can be written using record syntax:
::
- data T2 a b c = MkT2 { x %'Many :: a, y :: b, z :: c }
+ data T2 a b c = MkT2 { x %'Many :: a, y :: b, z %'Many :: c }
Again, the constructor ``MkT2`` has type ``MkT2 :: a -> b %1 -> c %1 -> T2 a b c``.
Note that by default record fields are linear, only unrestricted fields
-require a multiplicity annotation. The annotation has no effect on the record selectors.
-So ``x`` has type ``x :: T2 a b c -> a`` and similarly ``y`` has type ``y :: T2 a b c -> b``.
+require a multiplicity annotation.
+
+The multiplicity of record selectors is inferred from the multiplicity of the fields. Note that
+the effect of a selector is to discard all the other fields, so it can only be linear if all the
+other fields are unrestricted. So ``x`` has type ``x :: T2 a b c -> a``, because the ``y`` field
+is not unrestricted. But the ``x`` and ``z`` fields are unrestricted, so the selector for ``y``
+can be linear, and therefore it is made to be multiplicity-polymorphic: ``y :: T2 a b c %m -> b``.
+In particular this always applies to the selector of a newtype wrapper.
+
+In the case of multiple constructors, this logic is repeated for each constructor. So a selector
+is only made multiplicity-polymorphic if for every constructor all the other fields are unrestricted.
+(For technical reasons, partial record selectors cannot be made multiplicity-polymorphic, so they
+are always unrestricted.)
It is also possible to define a multiplicity-polymorphic field:
=====================================
testsuite/tests/linear/should_compile/LinearRecordSelector.hs
=====================================
@@ -0,0 +1,25 @@
+{-# LANGUAGE LinearTypes, DataKinds, OverloadedRecordDot, RebindableSyntax #-}
+module LinearRecordSelector where
+
+import GHC.Exts (Multiplicity(..))
+import Prelude
+
+getField :: ()
+getField = ()
+
+data Test = A { test :: Int, test2 %Many :: String } | B { test %Many :: Int, test3 %Many :: Char }
+
+test1 :: Test %1 -> Int
+test1 a = test a
+
+testM :: Test -> Int
+testM a = test a
+
+testX :: Test %m -> Int
+testX = test
+
+newtype NT = NT { unNT :: Int }
+
+nt :: NT %m -> Int
+nt a = unNT a
+
=====================================
testsuite/tests/linear/should_compile/all.T
=====================================
@@ -36,6 +36,7 @@ test('LinearTH3', normal, compile, [''])
test('LinearTH4', req_th, compile, [''])
test('LinearHole', normal, compile, [''])
test('LinearDataConSections', normal, compile, [''])
+test('LinearRecordSelector', normal, compile, ['-dcore-lint'])
test('T18731', normal, compile, [''])
test('T19400', unless(compiler_debugged(), skip), compile, [''])
test('T20023', normal, compile, [''])
=====================================
testsuite/tests/linear/should_fail/LinearRecordSelectorFail.hs
=====================================
@@ -0,0 +1,20 @@
+{-# LANGUAGE LinearTypes, DataKinds, OverloadedRecordDot, RebindableSyntax #-}
+module LinearRecordSelector where
+
+import GHC.Exts (Multiplicity(..))
+import Prelude
+
+getField :: ()
+getField = ()
+
+data Test1 = A1 { testA11 :: Int, testA12 :: String }
+
+-- Fails because testA12 is linear
+test1 :: Test1 %1 -> Int
+test1 a = testA11 a
+
+data Test2 = A2 { testA2 :: Int } | B2 { testB2 %Many :: Char }
+
+-- Fails because testA2 is partial
+test2 :: Test2 %1 -> Int
+test2 a = testA2 a
\ No newline at end of file
=====================================
testsuite/tests/linear/should_fail/LinearRecordSelectorFail.stderr
=====================================
@@ -0,0 +1,10 @@
+LinearRecordSelectorFail.hs:14:7: error: [GHC-18872]
+ • Couldn't match type ‘Many’ with ‘One’
+ arising from multiplicity of ‘a’
+ • In an equation for ‘test1’: test1 a = testA11 a
+
+LinearRecordSelectorFail.hs:20:7: error: [GHC-18872]
+ • Couldn't match type ‘Many’ with ‘One’
+ arising from multiplicity of ‘a’
+ • In an equation for ‘test2’: test2 a = testA2 a
+
=====================================
testsuite/tests/linear/should_fail/all.T
=====================================
@@ -11,6 +11,7 @@ test('LinearNoExt', normal, compile_fail, [''])
test('LinearNoExtU', normal, compile_fail, [''])
test('LinearAsPat', normal, compile_fail, [''])
test('LinearLazyPat', normal, compile_fail, [''])
+test('LinearRecordSelectorFail', normal, compile_fail, [''])
test('LinearRecordUpdate', normal, compile_fail, [''])
test('LinearSeq', normal, compile_fail, [''])
test('LinearViewPattern', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b087fcc4bdc9a6ee9c056de2a75ce4b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b087fcc4bdc9a6ee9c056de2a75ce4b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] x86 NCG: Fix code generation of bswap64 on i386
by Marge Bot (＠marge-bot) 06 Jun '25
by Marge Bot (＠marge-bot) 06 Jun '25
06 Jun '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
bfa6b70f by ARATA Mizuki at 2025-06-06T05:49:24-04:00
x86 NCG: Fix code generation of bswap64 on i386
Co-authored-by: sheaf <sam.derbyshire(a)gmail.com>
Fix #25601
- - - - -
5 changed files:
- compiler/GHC/CmmToAsm/X86/CodeGen.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
Changes:
=====================================
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
=====================================
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', '')], ''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bfa6b70f27dc2ce7fc890ec71103c40…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bfa6b70f27dc2ce7fc890ec71103c40…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Allow Unicode in "message" and "hints" with -fdiagnostics-as-json
by Marge Bot (＠marge-bot) 06 Jun '25
by Marge Bot (＠marge-bot) 06 Jun '25
06 Jun '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
05e9be18 by Simon Hengel at 2025-06-06T05:48:35-04:00
Allow Unicode in "message" and "hints" with -fdiagnostics-as-json
(fixes #26075)
- - - - -
3 changed files:
- compiler/GHC/Types/Error.hs
- testsuite/tests/driver/json.stderr
- testsuite/tests/driver/json_warn.stderr
Changes:
=====================================
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)
=====================================
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"}}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/05e9be1886a003482e4b059eb708b10…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/05e9be1886a003482e4b059eb708b10…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] AArch64 NCG: Fix sub-word arithmetic right shift
by Marge Bot (＠marge-bot) 06 Jun '25
by Marge Bot (＠marge-bot) 06 Jun '25
06 Jun '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
265d0024 by ARATA Mizuki at 2025-06-06T05:47:48-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
- - - - -
4 changed files:
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- + testsuite/tests/codeGen/should_run/T26061.hs
- + testsuite/tests/codeGen/should_run/T26061.stdout
- testsuite/tests/codeGen/should_run/all.T
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
=====================================
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, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/265d0024abc95be941f8e4769f24af1…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/265d0024abc95be941f8e4769f24af1…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] haddock: Parse math even after ordinary characters
by Marge Bot (＠marge-bot) 06 Jun '25
by Marge Bot (＠marge-bot) 06 Jun '25
06 Jun '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
6558467c by Ryan Hendrickson at 2025-06-06T05:46:58-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).
- - - - -
2 changed files:
- utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
- utils/haddock/haddock-library/test/Documentation/Haddock/ParserSpec.hs
Changes:
=====================================
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/-/commit/6558467c0e3a9b97141ec9f0cdbadf3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6558467c0e3a9b97141ec9f0cdbadf3…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
05 Jun '25
Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
880146d6 by Apoorv Ingle at 2025-06-05T22:40:47-05:00
do not suppress pprArising
- - - - -
3 changed files:
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Gen/Expr.hs
- testsuite/tests/indexed-types/should_fail/T5439.stderr
Changes:
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -5327,7 +5327,6 @@ pprArising :: CtLoc -> SDoc
-- Used for the main, top-level error message
-- We've done special processing for TypeEq, KindEq, givens
pprArising ct_loc
- | in_generated_code = empty -- See Note ["Arising from" messages in generated code]
| suppress_origin = empty
| otherwise = pprCtOrigin orig
where
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -295,7 +295,7 @@ tcExpr :: HsExpr GhcRn
-- These constructors are the union of
-- - ones taken apart by GHC.Tc.Gen.Head.splitHsApps
-- - ones understood by GHC.Tc.Gen.Head.tcInferAppHead_maybe
--- See Note [Application chains and heads] in GHC.Tc.Gen.Ap
+-- See Note [Application chains and heads] in GHC.Tc.Gen.App
tcExpr e@(HsVar {}) res_ty = tcApp (exprCtOrigin e) e res_ty
tcExpr e@(HsApp {}) res_ty = tcApp (exprCtOrigin e) e res_ty
tcExpr e@(OpApp {}) res_ty = tcApp (exprCtOrigin e) e res_ty
=====================================
testsuite/tests/indexed-types/should_fail/T5439.stderr
=====================================
@@ -1,4 +1,3 @@
-
T5439.hs:83:33: error: [GHC-83865]
• Couldn't match expected type: Attempt (HElemOf rs)
with actual type: Attempt (HHead (HDrop n0 l0))
@@ -6,8 +5,7 @@ T5439.hs:83:33: error: [GHC-83865]
• Probable cause: ‘($)’ is applied to too few arguments
In the second argument of ‘($)’, namely
‘inj $ Failure (e :: SomeException)’
- In a stmt of a 'do' block:
- c <- complete ev $ inj $ Failure (e :: SomeException)
+ In the expression: complete ev $ inj $ Failure (e :: SomeException)
In the expression:
do c <- complete ev $ inj $ Failure (e :: SomeException)
return $ c || not first
@@ -28,5 +26,5 @@ T5439.hs:83:39: error: [GHC-83865]
‘Failure (e :: SomeException)’
In the second argument of ‘($)’, namely
‘inj $ Failure (e :: SomeException)’
- In a stmt of a 'do' block:
- c <- complete ev $ inj $ Failure (e :: SomeException)
+ In the expression: complete ev $ inj $ Failure (e :: SomeException)
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/880146d68eee678c82002c89e92bac2…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/880146d68eee678c82002c89e92bac2…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: haddock: Parse math even after ordinary characters
by Marge Bot (＠marge-bot) 05 Jun '25
by Marge Bot (＠marge-bot) 05 Jun '25
05 Jun '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
54bc301b by Ryan Hendrickson at 2025-06-05T22:46:14-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).
- - - - -
945dc0a8 by ARATA Mizuki at 2025-06-05T22:46:20-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
- - - - -
572cf06a by Simon Hengel at 2025-06-05T22:46:23-04:00
Allow Unicode in "message" and "hints" with -fdiagnostics-as-json
(fixes #26075)
- - - - -
eec6dd1b by ARATA Mizuki at 2025-06-05T22:46:26-04:00
x86 NCG: Fix code generation of bswap64 on i386
Co-authored-by: sheaf <sam.derbyshire(a)gmail.com>
Fix #25601
- - - - -
14 changed files:
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/Types/Error.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)
=====================================
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/04df08c3abcf0e15b60ba003978c14…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/04df08c3abcf0e15b60ba003978c14…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/spj-apporv-Oct24] 20 commits: Make GHCi commands compatible with multiple home units
by Apoorv Ingle (＠ani) 05 Jun '25
by Apoorv Ingle (＠ani) 05 Jun '25
05 Jun '25
Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
5f213bff by fendor at 2025-06-02T09:16:24+02:00
Make GHCi commands compatible with multiple home units
=== Design
We enable all GHCi features that were previously guarded by the `inMulti`
option.
GHCi supported multiple home units up to a certain degree for quite a while now.
The supported feature set was limited, due to a design impasse:
One of the home units must be "active", e.g., there must be one `HomeUnit`
whose `UnitId` is "active" which is returned when calling
```haskell
do
hscActiveUnitId <$> getSession
```
This makes sense in a GHC session, since you are always compiling a particular
Module, but it makes less intuitive sense in an interactive session.
Given an expression to evaluate, we can't easily tell in which "context" the expression
should be parsed, typechecked and evaluated.
That's why initially, most of GHCi features, except for `:reload`ing were disabled
if the GHCi session had more than one `HomeUnitEnv`.
We lift this restriction, enabling all features of GHCi for the multiple home unit case.
To do this, we fundamentally change the `HomeUnitEnv` graph to be multiple home unit first.
Instead of differentiating the case were we have a single home unit and multiple,
we now always set up a multiple home unit session that scales seamlessly to an arbitrary
amount of home units.
We introduce two new `HomeUnitEnv`s that are always added to the `HomeUnitGraph`.
They are:
The "interactive-ghci", called the `interactiveGhciUnit`, contains the same
`DynFlags` that are used by the `InteractiveContext` for interactive evaluation
of expressions.
This `HomeUnitEnv` is only used on the prompt of GHCi, so we may refer to it as
"interactive-prompt" unit.
See Note [Relation between the `InteractiveContext` and `interactiveGhciUnitId`]
for discussing its role.
And the "interactive-session"", called `interactiveSessionUnit` or
`interactiveSessionUnitId`, which is used for loading Scripts into
GHCi that are not `Target`s of any home unit, via `:load` or `:add`.
Both of these "interactive" home units depend on all other `HomeUnitEnv`s that
are passed as arguments on the cli.
Additionally, the "interactive-ghci" unit depends on `interactive-session`.
We always evaluate expressions in the context of the
"interactive-ghci" session.
Since "interactive-ghci" depends on all home units, we can import any `Module`
from the other home units with ease.
As we have a clear `HomeUnitGraph` hierarchy, we can set `interactiveGhciUnitId`
as the active home unit for the full duration of the GHCi session.
In GHCi, we always set `interactiveGhciUnitId` to be the currently active home unit.
=== Implementation Details
Given this design idea, the implementation is relatively straight
forward.
The core insight is that a `ModuleName` is not sufficient to identify a
`Module` in the `HomeUnitGraph`. Thus, large parts of the PR is simply
about refactoring usages of `ModuleName` to prefer `Module`, which has a
`Unit` attached and is unique over the `HomeUnitGraph`.
Consequentially, most usages of `lookupHPT` are likely to be incorrect and have
been replaced by `lookupHugByModule` which is keyed by a `Module`.
In `GHCi/UI.hs`, we make sure there is only one location where we are
actually translating `ModuleName` to a `Module`:
* `lookupQualifiedModuleName`
If a `ModuleName` is ambiguous, we detect this and report it to the
user.
To avoid repeated lookups of `ModuleName`s, we store the `Module` in the
`InteractiveImport`, which additionally simplifies the interface
loading.
A subtle detail is that the `DynFlags` of the `InteractiveContext` are
now stored both in the `HomeUnitGraph` and in the `InteractiveContext`.
In UI.hs, there are multiple code paths where we are careful to update
the `DynFlags` in both locations.
Most importantly in `addToProgramDynFlags`.
---
There is one metric increase in this commit:
-------------------------
Metric Increase:
T4029
-------------------------
It is an increase from 14.4 MB to 16.1 MB (+11.8%) which sounds like a
pretty big regression at first.
However, we argue this increase is solely caused by using more data
structures for managing multiple home units in the GHCi session.
In particular, due to the design decision of using three home units, the
base memory usage increases... but by how much?
A big contributor is the `UnitState`, of which we have three now, which
on its own 260 KB per instance. That makes an additional memory usage of
520 KB, already explaining a third of the overall memory usage increase.
Then we store more elements in the `HomeUnitGraph`, we have more
`HomeUnitEnv` entries, etc...
While we didn't chase down each byte, we looked at the memory usage over time
for both `-hi` and `-hT` profiles and can say with confidence while the memory
usage increased slightly, we did not introduce any space leak, as
the graph looks almost identical as the memory usage graph of GHC HEAD.
---
Adds testcases for GHCi multiple home units session
* Test truly multiple home unit sessions, testing reload logic and code evaluation.
* Test that GHCi commands such as `:all-types`, `:browse`, etc., work
* Object code reloading for home modules
* GHCi debugger multiple home units session
- - - - -
de603d01 by fendor at 2025-06-02T09:16:24+02:00
Update "loading compiled code" GHCi documentation
To use object code in GHCi, the module needs to be compiled for use in
GHCi. To do that, users need to compile their modules with:
* `-dynamic`
* `-this-unit-id interactive-session`
Otherwise, the interface files will not match.
- - - - -
b255a8ca by Vladislav Zavialov at 2025-06-02T16:00:12-04:00
docs: Fix code example for NoListTuplePuns
Without the fix, the example produces an error:
Test.hs:11:3: error: [GHC-45219]
• Data constructor ‘Tuple’ returns type ‘Tuple2 a b’
instead of an instance of its parent type ‘Tuple a’
• In the definition of data constructor ‘Tuple’
In the data type declaration for ‘Tuple’
Fortunately, a one line change makes it compile.
- - - - -
9f51d952 by Apoorv Ingle at 2025-06-05T17:15:45-05:00
- Remove one `SrcSpan` field from `VAExpansion`. It is no longer needed.
- Make `tcExpr` take a `Maybe HsThingRn` which will be passed on to tcApp and used by splitHsApps to determine a more accurate `AppCtx`
- `tcXExpr` is less hacky now
- do not look through HsExpansion applications
- kill OrigPat and remove HsThingRn From VAExpansion
- look through XExpr ExpandedThingRn while inferring type of head
- always set in generated code after stepping inside a ExpandedThingRn
- fixing record update error messages
- remove special case of tcbody from tcLambdaMatches
- wrap last stmt expansion in a HsPar so that the error messages are prettier
- remove special case of dsExpr for ExpandedThingTc
- make EExpand (HsExpr GhcRn) instead of EExpand HsThingRn
- fixing error messages for rebindable
- - - - -
86251b13 by Apoorv Ingle at 2025-06-05T17:15:45-05:00
some progress on tick
- - - - -
2fd9e8ce by Apoorv Ingle at 2025-06-05T17:15:45-05:00
remove adhoc cases from ticks
- - - - -
11f767e6 by Apoorv Ingle at 2025-06-05T17:15:45-05:00
fix the case where head of the application chain is an expanded expression and the argument is a type application c.f. T19167.hs
- - - - -
c9e2bdd1 by Apoorv Ingle at 2025-06-05T17:15:45-05:00
move setQLInstLevel inside tcInstFun
- - - - -
becc473a by Apoorv Ingle at 2025-06-05T17:15:45-05:00
ignore ds warnings originating from gen locations
- - - - -
e88f1687 by Apoorv Ingle at 2025-06-05T17:15:45-05:00
filter expr stmts error msgs
- - - - -
cfd7e10a by Apoorv Ingle at 2025-06-05T17:15:45-05:00
exception for AppDo while making error ctxt
- - - - -
b2195635 by Apoorv Ingle at 2025-06-05T17:15:45-05:00
moving around things for locations and error ctxts
- - - - -
2823806b by Apoorv Ingle at 2025-06-05T17:15:45-05:00
popErrCtxt doesn't push contexts and popErrCtxts in the first argument to bind and >> in do expansion statements
- - - - -
f3b6eb3c by Apoorv Ingle at 2025-06-05T17:15:45-05:00
accept test cases with changed error messages
-------------------------
Metric Decrease:
T9020
-------------------------
- - - - -
6d259023 by Apoorv Ingle at 2025-06-05T17:15:45-05:00
look through PopErrCtxt while splitting exprs in application chains
- - - - -
43db9ee8 by Apoorv Ingle at 2025-06-05T17:15:45-05:00
remove special case for HsExpanded in Ticks
- - - - -
743ad9d5 by Apoorv Ingle at 2025-06-05T17:15:45-05:00
check the right origin for record selector incomplete warnings
- - - - -
cd6c239c by Apoorv Ingle at 2025-06-05T17:15:45-05:00
kill VAExpansion
- - - - -
800ac3cd by Apoorv Ingle at 2025-06-05T17:15:46-05:00
pass CtOrigin to tcApp for instantiateSigma
- - - - -
169edd9c by Apoorv Ingle at 2025-06-05T17:15:46-05:00
do not suppress pprArising
- - - - -
172 changed files:
- compiler/GHC.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Unbound.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Gen/App.hs
- + compiler/GHC/Tc/Gen/App.hs-boot
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Name/Ppr.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Home/Graph.hs
- compiler/GHC/Unit/Types.hs
- docs/users_guide/exts/data_kinds.rst
- docs/users_guide/ghci.rst
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Exception.hs
- ghc/GHCi/UI/Info.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.hs
- testsuite/driver/testlib.py
- testsuite/tests/deSugar/should_compile/T10662.stderr
- testsuite/tests/deSugar/should_compile/T3263-1.stderr
- testsuite/tests/deSugar/should_compile/T3263-2.stderr
- testsuite/tests/default/default-fail05.stderr
- testsuite/tests/driver/T8526/T8526.stdout
- testsuite/tests/driver/fat-iface/fat014.stdout
- testsuite/tests/driver/multipleHomeUnits/multiGHCi.stderr
- testsuite/tests/ghc-api/T6145.hs
- testsuite/tests/ghc-api/annotations-literals/literals.hs
- testsuite/tests/ghc-api/annotations-literals/parsed.hs
- testsuite/tests/ghc-api/apirecomp001/myghc.hs
- testsuite/tests/ghc-api/fixed-nodes/T1.hs
- + testsuite/tests/ghci.debugger/scripts/break031/Makefile
- + testsuite/tests/ghci.debugger/scripts/break031/a/A.hs
- + testsuite/tests/ghci.debugger/scripts/break031/all.T
- + testsuite/tests/ghci.debugger/scripts/break031/b/B.hs
- + testsuite/tests/ghci.debugger/scripts/break031/break031a.script
- + testsuite/tests/ghci.debugger/scripts/break031/break031a.stdout
- + testsuite/tests/ghci.debugger/scripts/break031/break031b.script
- + testsuite/tests/ghci.debugger/scripts/break031/break031b.stderr
- + testsuite/tests/ghci.debugger/scripts/break031/break031b.stdout
- + testsuite/tests/ghci.debugger/scripts/break031/unitA
- + testsuite/tests/ghci.debugger/scripts/break031/unitB
- testsuite/tests/ghci/linking/dyn/T3372.hs
- + testsuite/tests/ghci/prog-mhu001/Makefile
- + testsuite/tests/ghci/prog-mhu001/all.T
- + testsuite/tests/ghci/prog-mhu001/e/E.hs
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001a.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001a.stdout
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001b.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001b.stdout
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001c.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001c.stdout
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001d.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001d.stdout
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001e.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001e.stdout
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001f.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001f.stdout
- + testsuite/tests/ghci/prog-mhu001/unitE
- + testsuite/tests/ghci/prog-mhu001/unitE-main-is
- + testsuite/tests/ghci/prog-mhu002/Makefile
- + testsuite/tests/ghci/prog-mhu002/a/A.hs
- + testsuite/tests/ghci/prog-mhu002/all.T
- + testsuite/tests/ghci/prog-mhu002/b/B.hs
- + testsuite/tests/ghci/prog-mhu002/c/C.hs
- + testsuite/tests/ghci/prog-mhu002/d/Main.hs
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002a.script
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002a.stderr
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002a.stdout
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002b.script
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002b.stderr
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002b.stdout
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002c.script
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002c.stdout
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002d.script
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002d.stdout
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002e.script
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002e.stdout
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002f.script
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002f.stdout
- + testsuite/tests/ghci/prog-mhu002/unitA
- + testsuite/tests/ghci/prog-mhu002/unitB
- + testsuite/tests/ghci/prog-mhu002/unitC
- + testsuite/tests/ghci/prog-mhu002/unitD
- + testsuite/tests/ghci/prog-mhu003/Makefile
- + testsuite/tests/ghci/prog-mhu003/a/A.hs
- + testsuite/tests/ghci/prog-mhu003/all.T
- + testsuite/tests/ghci/prog-mhu003/b/Foo.hs
- + testsuite/tests/ghci/prog-mhu003/c/C.hs
- + testsuite/tests/ghci/prog-mhu003/d/Foo.hs
- + testsuite/tests/ghci/prog-mhu003/prog-mhu003.script
- + testsuite/tests/ghci/prog-mhu003/prog-mhu003.stderr
- + testsuite/tests/ghci/prog-mhu003/prog-mhu003.stdout
- + testsuite/tests/ghci/prog-mhu003/unitA
- + testsuite/tests/ghci/prog-mhu003/unitB
- + testsuite/tests/ghci/prog-mhu003/unitC
- + testsuite/tests/ghci/prog-mhu003/unitD
- + testsuite/tests/ghci/prog-mhu004/Makefile
- + testsuite/tests/ghci/prog-mhu004/a/Foo.hs
- + testsuite/tests/ghci/prog-mhu004/all.T
- + testsuite/tests/ghci/prog-mhu004/b/Foo.hs
- + testsuite/tests/ghci/prog-mhu004/prog-mhu004a.script
- + testsuite/tests/ghci/prog-mhu004/prog-mhu004a.stderr
- + testsuite/tests/ghci/prog-mhu004/prog-mhu004a.stdout
- + testsuite/tests/ghci/prog-mhu004/prog-mhu004b.script
- + testsuite/tests/ghci/prog-mhu004/prog-mhu004b.stdout
- + testsuite/tests/ghci/prog-mhu004/unitA
- + testsuite/tests/ghci/prog-mhu004/unitB
- testsuite/tests/ghci/prog010/ghci.prog010.script
- testsuite/tests/ghci/prog018/prog018.stdout
- + testsuite/tests/ghci/prog020/A.hs
- + testsuite/tests/ghci/prog020/B.hs
- + testsuite/tests/ghci/prog020/Makefile
- + testsuite/tests/ghci/prog020/all.T
- + testsuite/tests/ghci/prog020/ghci.prog020.script
- + testsuite/tests/ghci/prog020/ghci.prog020.stderr
- + testsuite/tests/ghci/prog020/ghci.prog020.stdout
- testsuite/tests/ghci/scripts/T13869.stdout
- testsuite/tests/ghci/scripts/T13997.stdout
- testsuite/tests/ghci/scripts/T17669.stdout
- testsuite/tests/ghci/scripts/T18330.stdout
- testsuite/tests/ghci/scripts/T1914.stdout
- testsuite/tests/ghci/scripts/T20217.stdout
- testsuite/tests/ghci/scripts/T20587.stdout
- testsuite/tests/ghci/scripts/T21110.stderr
- testsuite/tests/ghci/scripts/T6105.stdout
- testsuite/tests/ghci/scripts/T8042.stdout
- testsuite/tests/ghci/scripts/T8042recomp.stdout
- testsuite/tests/ghci/scripts/ghci024.stdout
- testsuite/tests/ghci/scripts/ghci024.stdout-mingw32
- testsuite/tests/ghci/scripts/ghci058.script
- testsuite/tests/ghci/should_run/TopEnvIface.stdout
- testsuite/tests/indexed-types/should_fail/T2693.stderr
- testsuite/tests/indexed-types/should_fail/T5439.stderr
- testsuite/tests/plugins/test-defaulting-plugin.stderr
- testsuite/tests/polykinds/T13393.stderr
- testsuite/tests/printer/T17697.stderr
- testsuite/tests/quasiquotation/T7918.hs
- testsuite/tests/typecheck/should_compile/T14590.stderr
- testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr
- testsuite/tests/typecheck/should_fail/DoExpansion1.stderr
- testsuite/tests/typecheck/should_fail/DoExpansion2.stderr
- testsuite/tests/typecheck/should_fail/T10971d.stderr
- testsuite/tests/typecheck/should_fail/T13311.stderr
- testsuite/tests/typecheck/should_fail/T24064.stderr
- testsuite/tests/typecheck/should_fail/T3613.stderr
- testsuite/tests/typecheck/should_fail/T7851.stderr
- testsuite/tests/typecheck/should_fail/T8603.stderr
- testsuite/tests/typecheck/should_fail/T9612.stderr
- testsuite/tests/typecheck/should_fail/tcfail128.stderr
- testsuite/tests/typecheck/should_fail/tcfail168.stderr
- testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b312c7ba5b6b358c124e2c633fecd6…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b312c7ba5b6b358c124e2c633fecd6…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: haddock: Parse math even after ordinary characters
by Marge Bot (＠marge-bot) 05 Jun '25
by Marge Bot (＠marge-bot) 05 Jun '25
05 Jun '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
fe1c24ca by Ryan Hendrickson at 2025-06-05T17:14:41-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).
- - - - -
08225327 by ARATA Mizuki at 2025-06-05T17:14:46-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
- - - - -
343653e8 by Simon Hengel at 2025-06-05T17:14:48-04:00
Allow Unicode in "message" and "hints" with -fdiagnostics-as-json
(fixes #26075)
- - - - -
04df08c3 by ARATA Mizuki at 2025-06-05T17:14:52-04:00
x86 NCG: Fix code generation of bswap64 on i386
Co-authored-by: sheaf <sam.derbyshire(a)gmail.com>
Fix #25601
- - - - -
14 changed files:
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/Types/Error.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)
=====================================
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/06314b7c234a4025f0a238116dcef7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/06314b7c234a4025f0a238116dcef7…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: hadrian: Place user options after package arguments
by Marge Bot (＠marge-bot) 05 Jun '25
by Marge Bot (＠marge-bot) 05 Jun '25
05 Jun '25
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 <sam.derbyshire(a)gmail.com>
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/4de53bb43a0b92fcade65847d0841b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4de53bb43a0b92fcade65847d0841b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0