Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 5c4c3bf4 by Sylvain Henry at 2026-05-02T03:39:28-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) - - - - - e242ce4f by Sylvain Henry at 2026-05-02T03:39:28-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) - - - - - 2 changed files: - testsuite/tests/MiniQuickCheck.hs - testsuite/tests/numeric/should_run/foundation.hs Changes: ===================================== 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/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/391413435eb02d9d8ed8bb85946de2d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/391413435eb02d9d8ed8bb85946de2d... You're receiving this email because of your account on gitlab.haskell.org.