Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
081b61dc by Sylvain Henry at 2026-05-01T18:07:43-04:00
testsuite: fix flaky foundation Divisible / mulIntMayOflo# tests (#27222)
Since the LCG was widened to 64 bits and the seed randomised per CI run
(commit 2d30f7d3400 "Vendor mini-QuickCheck for testsuite"), two latent
bugs in the foundation test surface stochastically:
* The Divisible property `(x `div` y) * y + (x `mod` y) == x` raises
ArithException(Overflow) when (a, b) = (minBound, -1) for fixed-width
signed Integral types. Split testNumber/testDivisible into Bounded and
unbounded variants and skip just that one pair, gated by
`(minBound :: a) < 0` so unsigned types lose no coverage.
* The `mulIntMayOflo#` test compared raw Int# bit-for-bit, but the primop
is only specified to return 0/non-zero -- the exact non-zero indicator
legitimately differs between backends and inlining choices. Add a
dedicated `testPrimopMayOflo` helper that only compares zero / non-zero.
Also fix the long-standing typo "Dividible" -> "Divisible" in identifiers.
Co-Authored-By: Claude Opus 4.7 (1M context)
- - - - -
31f7d38b by Sylvain Henry at 2026-05-01T18:07:43-04:00
testsuite: catch and display exceptions in MiniQuickCheck
Exceptions raised while evaluating a property are now caught and reported
as a normal failure (with arguments and seed), instead of aborting the
test.
Co-Authored-By: Claude Opus 4.7 (1M context)
- - - - -
4441dabb by fendor at 2026-05-01T18:07:44-04:00
Fix name of Note [Structure of dep_boot_mods]
- - - - -
4 changed files:
- compiler/GHC/Unit/Module/Deps.hs
- testsuite/tests/MiniQuickCheck.hs
- testsuite/tests/linters/notes.stdout
- testsuite/tests/numeric/should_run/foundation.hs
Changes:
=====================================
compiler/GHC/Unit/Module/Deps.hs
=====================================
@@ -96,7 +96,7 @@ data Dependencies = Deps
, dep_boot_mods_ :: Set (UnitId, ModuleNameWithIsBoot)
-- ^ All modules which have boot files below this one, and whether we
-- should use the boot file or not.
- -- This information is only used to populate the eps_is_boot field.
+ -- This information is only used to populate the 'eps_is_boot' field.
-- See Note [Structure of dep_boot_mods]
, dep_orphs_ :: [Module]
@@ -605,7 +605,7 @@ hash of the module. The export hash is computed in `GHC.Iface.Recomp.addFingerpr
-}
{-
-Note [Structure of dep_boot_deps]
+Note [Structure of dep_boot_mods]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In `-c` mode we always need to know whether to load the normal or boot version of
=====================================
testsuite/tests/MiniQuickCheck.hs
=====================================
@@ -2,6 +2,7 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
-- | A minimal QuickCheck-like property testing framework for use in the GHC
@@ -52,6 +53,8 @@ module MiniQuickCheck
) where
-- base
+import Control.Exception
+ ( SomeException, displayException, evaluate, try )
import Control.Monad.IO.Class
( liftIO )
import Data.Bits
@@ -181,16 +184,39 @@ nest :: String -> ReaderT RunS IO a -> ReaderT RunS IO a
nest c = local (\s -> s { depth = depth s + 1, context = c : context s })
runPropertyCheck :: PropertyCheck -> ReaderT RunS IO Result
-runPropertyCheck (PropertyBinaryOp ok desc s1 s2) =
- if ok
- then return Success
- else do
- ctx <- context <$> ask
- let msg = "Failure: " ++ s1 ++ " " ++ desc ++ " " ++ s2
- putMsg msg
- return (Failure [msg : ctx])
-runPropertyCheck (PropertyAnd a b) =
- (<>) <$> runPropertyCheck a <*> runPropertyCheck b
+runPropertyCheck pcThunk = do
+ -- See Note [Catching exceptions in property evaluation].
+ pcRes <- liftIO $ try @SomeException (evaluate pcThunk)
+ case pcRes of
+ Left e -> reportFailure ("Failure: exception: " ++ displayException e)
+ Right (PropertyAnd a b) ->
+ (<>) <$> runPropertyCheck a <*> runPropertyCheck b
+ Right (PropertyBinaryOp ok desc s1 s2) -> do
+ okRes <- liftIO $ try @SomeException (evaluate ok)
+ case okRes of
+ Right True -> return Success
+ Right False -> reportFailure ("Failure: " ++ s1 ++ " " ++ desc ++ " " ++ s2)
+ Left e -> reportFailure ("Failure: exception: " ++ displayException e)
+
+reportFailure :: String -> ReaderT RunS IO Result
+reportFailure msg = do
+ ctx <- context <$> ask
+ putMsg msg
+ return (Failure [msg : ctx])
+
+-- Note [Catching exceptions in property evaluation]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- A property like `\a b -> let !r = a `div` 0 in r === b` builds a
+-- `PropertyCheck` thunk whose forcing raises an exception -- in this case
+-- already at the `PropertyBinaryOp` constructor, before its `ok` field is
+-- ever inspected. Other properties may force `ok = (s1 == s2)` instead and
+-- raise from there.
+--
+-- To handle both, we `evaluate` first the `PropertyCheck` thunk and then
+-- the `ok` field, each inside `try`, and report any exception through the
+-- normal `reportFailure` path. The surrounding loop then still prints
+-- "With arguments ... (Seed: ...)" and the test driver continues with
+-- subsequent properties instead of aborting.
runProperty :: Iterations -> Property -> ReaderT RunS IO Result
runProperty (Iterations iters) (Prop p) = do
=====================================
testsuite/tests/linters/notes.stdout
=====================================
@@ -27,7 +27,6 @@ ref compiler/GHC/Tc/Solver/Rewrite.hs:1020:7: Note [Stability of rewritin
ref compiler/GHC/Tc/TyCl.hs:1662:6: Note [Unification variables need fresh Names]
ref compiler/GHC/Tc/Types/Constraint.hs:209:9: Note [NonCanonical Semantics]
ref compiler/GHC/Types/Demand.hs:304:25: Note [Preserving Boxity of results is rarely a win]
-ref compiler/GHC/Unit/Module/Deps.hs:97:13: Note [Structure of dep_boot_mods]
ref compiler/GHC/Utils/Monad.hs:415:34: Note [multiShotIO]
ref compiler/Language/Haskell/Syntax/Binds.hs:206:31: Note [fun_id in Match]
ref configure.ac:205:10: Note [Linking ghc-bin against threaded stage0 RTS]
=====================================
testsuite/tests/numeric/should_run/foundation.hs
=====================================
@@ -77,13 +77,42 @@ testMultiplicative _ = Group "Multiplicative"
, Property "a * b == Integer(a) * Integer(b)" $ \(a :: a) (b :: a) -> a * b === fromInteger (toInteger a * toInteger b)
]
-testDividible :: forall a . (Show a, Eq a, Integral a, Num a, Arbitrary a, Typeable a)
+-- | Divisibility test for Bounded Integral types (Int, Int{8,16,32,64},
+-- Word, Word{8,16,32,64}).
+testDivisible :: forall a . (Show a, Eq a, Bounded a, Integral a, Num a, Arbitrary a, Typeable a)
=> Proxy a -> Test
-testDividible _ = Group "Divisible"
+testDivisible _ = Group "Divisible"
+ [ Property "(x `div` y) * y + (x `mod` y) == x" $ \(a :: a) (NonZero b) ->
+ -- See Note [Skipping minBound `div` (-1)].
+ if (minBound :: a) < 0 && a == minBound && b == (-1)
+ then True === True
+ else a === (a `div` b) * b + (a `mod` b)
+ ]
+
+-- | Divisibility test for unbounded Integral types (Integer). No overflow
+-- can occur here, so the property holds without exception for all NonZero b.
+testDivisibleUnbounded :: forall a . (Show a, Eq a, Integral a, Num a, Arbitrary a, Typeable a)
+ => Proxy a -> Test
+testDivisibleUnbounded _ = Group "Divisible"
[ Property "(x `div` y) * y + (x `mod` y) == x" $ \(a :: a) (NonZero b) ->
a === (a `div` b) * b + (a `mod` b)
]
+-- Note [Skipping minBound `div` (-1)]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- For a fixed-width *signed* Integral type, `minBound `div` (-1)` raises
+-- ArithException(Overflow) because `-minBound` is not representable in the
+-- type (e.g., for Int8, `-(-128)` would be 128, out of range). The div/mod
+-- identity property cannot hold there, so we skip exactly that one pair.
+--
+-- We detect "signed Bounded" with `(minBound :: a) < 0`: True for Int{N},
+-- False for Word{N}. This way unsigned Bounded types lose no coverage,
+-- and only the genuine overflow sample is skipped for signed types.
+--
+-- For the unbounded `Integer`, no overflow can occur and we use a separate
+-- 'testDivisibleUnbounded' (without the Bounded constraint or the skip).
+-- See #27222.
+
testOperatorPrecedence :: forall a . (Show a, Eq a, Prelude.Num a, Integral a, Num a, Arbitrary a, Typeable a)
=> Proxy a -> Test
testOperatorPrecedence _ = Group "Precedence"
@@ -101,14 +130,26 @@ testOperatorPrecedence _ = Group "Precedence"
]
-testNumber :: (Show a, Eq a, Prelude.Num a, Integral a, Num a, Arbitrary a, Typeable a)
+testNumber :: (Show a, Eq a, Prelude.Num a, Bounded a, Integral a, Num a, Arbitrary a, Typeable a)
=> String -> Proxy a -> Test
testNumber name proxy = Group name
[ testIntegral proxy
, testEqOrd proxy
, testAdditive proxy
, testMultiplicative proxy
- , testDividible proxy
+ , testDivisible proxy
+ , testOperatorPrecedence proxy
+ ]
+
+-- | Variant of 'testNumber' for unbounded Integral types (e.g., Integer).
+testNumberUnbounded :: (Show a, Eq a, Prelude.Num a, Integral a, Num a, Arbitrary a, Typeable a)
+ => String -> Proxy a -> Test
+testNumberUnbounded name proxy = Group name
+ [ testIntegral proxy
+ , testEqOrd proxy
+ , testAdditive proxy
+ , testMultiplicative proxy
+ , testDivisibleUnbounded proxy
, testOperatorPrecedence proxy
]
@@ -119,7 +160,7 @@ testNumberRefs = Group "ALL"
, testNumber "Int16" (Proxy :: Proxy Int16)
, testNumber "Int32" (Proxy :: Proxy Int32)
, testNumber "Int64" (Proxy :: Proxy Int64)
- , testNumber "Integer" (Proxy :: Proxy Integer)
+ , testNumberUnbounded "Integer" (Proxy :: Proxy Integer)
, testNumber "Word" (Proxy :: Proxy Word)
, testNumber "Word8" (Proxy :: Proxy Word8)
, testNumber "Word16" (Proxy :: Proxy Word16)
@@ -399,7 +440,7 @@ testPrimops = Group "primop"
, testPrimop "-#" (Primop.-#) (Wrapper.-#)
, testPrimop "*#" (Primop.*#) (Wrapper.*#)
, testPrimop "timesInt2#" Primop.timesInt2# Wrapper.timesInt2#
- , testPrimop "mulIntMayOflo#" Primop.mulIntMayOflo# Wrapper.mulIntMayOflo#
+ , testPrimopMayOflo "mulIntMayOflo#" Primop.mulIntMayOflo# Wrapper.mulIntMayOflo#
, testPrimopDivLike "quotInt#" Primop.quotInt# Wrapper.quotInt#
, testPrimopDivLike "remInt#" Primop.remInt# Wrapper.remInt#
, testPrimopDivLike "quotRemInt#" Primop.quotRemInt# Wrapper.quotRemInt#
@@ -497,6 +538,31 @@ instance TestPrimop (Int# -> Int# -> Int#) where
testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
testPrimopShift s l r = Property s $ \ (uInt#-> x0) (BoundedShiftAmount @Int shift) -> wInt# (l x0 (uInt# shift)) === wInt# (r x0 (uInt# shift))
+-- | Compare two 'mulIntMayOflo#'-like primops only on whether their result
+-- is zero. See Note [Comparing mulIntMayOflo# results].
+testPrimopMayOflo :: String
+ -> (Int# -> Int# -> Int#)
+ -> (Int# -> Int# -> Int#)
+ -> Test
+testPrimopMayOflo s l r =
+ Property s $ \ (uInt# -> x0) (uInt# -> x1) ->
+ (wInt# (l x0 x1) == 0) === (wInt# (r x0 x1) == 0)
+
+-- Note [Comparing mulIntMayOflo# results]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- The 'mulIntMayOflo#' primop is only specified to return 0 if the signed
+-- multiplication does not overflow, and a non-zero value if it /may/
+-- overflow (see Note [MO_S_MulMayOflo significant width] in
+-- GHC.Cmm.MachOp). The exact non-zero value is unspecified and legitimately
+-- differs between backends and between inlined vs. non-inlined call sites
+-- (e.g., the LLVM backend's `isSMulOK` returns `sext_signbit(low) - high`,
+-- which is some arbitrary non-zero word on overflow).
+--
+-- Comparing the raw Int# results bit-for-bit is therefore too strict and
+-- causes spurious test failures whenever the random arguments happen to
+-- overflow. We compare zero/non-zero instead, which matches the spec.
+-- See #27222.
+
instance TestPrimop (Int# -> Int# -> (# Int#,Int# #)) where
testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1))
testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1))
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/74afb3b7a62c52dedc0eb694257fe87...
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/74afb3b7a62c52dedc0eb694257fe87...
You're receiving this email because of your account on gitlab.haskell.org.
