- ghc-commits - Haskell.org

[Git][ghc/ghc] Pushed new branch wip/stm-mvar-deadlock-backtrace
by Ben Gamari (＠bgamari) 09 Jun '26

09 Jun '26

Ben Gamari pushed new branch wip/stm-mvar-deadlock-backtrace at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/stm-mvar-deadlock-backtrace You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/loop-backtrace
by Ben Gamari (＠bgamari) 09 Jun '26

09 Jun '26

Ben Gamari pushed new branch wip/loop-backtrace at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/loop-backtrace You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/21176-integer-bits] 5 commits: Hadrian: convert env variable ACLOCAL_PATH to unix paths.
by Simon Jakobi (＠sjakobi2) 09 Jun '26

09 Jun '26

Simon Jakobi pushed to branch wip/sjakobi/21176-integer-bits at Glasgow Haskell Compiler / GHC Commits: a3b431f3 by David Eichmann at 2026-06-04T10:10:19+00:00 Hadrian: convert env variable ACLOCAL_PATH to unix paths. Convert ACLOCAL_PATH to a unix style path when invoking autoreconf. Autoreconf doesn't handle windows paths. See Note [Autoreconf unix paths from ACLOCAL_PATH]. Fixes #27311 - - - - - 18f6138a by Simon Jakobi at 2026-06-04T20:20:31-04:00 testsuite: Deduplicate --only test names config.only is assumed to be a set, but supplying --only overwrote it with the (list) argparse result, which can contain duplicates. When a test ran, config.only.remove(name) dropped only the first occurrence, so a duplicated name lingered and was later misreported as a "test not found" framework failure. Store it as a set instead. Fixes #27322 Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - 2f3cc9ff by Simon Jakobi at 2026-06-08T07:55:49-04:00 testsuite: detect fast bignum via ghc-internal, not removed ghc-bignum The ghc-bignum package was merged into ghc-internal, so the BIGNUM_GMP probe in test.mk ran `ghc-pkg field ghc-bignum exposed-modules`, which fails with "cannot find package ghc-bignum". That error went to stderr and leaked into the captured stderr of every makefile_test, causing spurious [bad stderr] failures across the suite. The probe also silently returned empty, so config.have_fast_bignum was wrongly False even on GMP builds. Probe ghc-internal's extra-libraries for the gmp library instead: the GMP backend module is an other-module (not exposed), but GMP_LIBS adds gmp to extra-libraries only on a GMP build, so this distinguishes the backends. Redirect stderr to keep any future missing-package error off the harness's stderr. This also removes a stale comment as per suggestion from hsyl20. Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - eb3bf6e7 by Alan Zimmerman at 2026-06-08T07:56:32-04:00 EPA: Rename Transform.anchorEof to addModuleCommentOrigDeltas This now matches what it actually does. - - - - - 46e87880 by Simon Jakobi at 2026-06-09T14:41:55+02:00 Add explicit setBit/clearBit/complementBit for instance Bits Integer (#21176) The default setBit, clearBit, and complementBit methods allocate intermediate Integers per call. Define them explicitly via the new integerSetBit[#], integerClearBit[#] and integerComplementBit[#], built on the BigNat# primitives, which avoid those allocations. Allocation is not eliminated entirely -- the negative (IN) cases would need in-place mutation, which is left as future work. The default methods constant-folded on literal arguments via the integerOr/integerAnd/integerXor rules, which fold literal Integers of any size. The explicit functions have no such rule, so they (their Word-argument wrappers, and the Bits Integer methods) are marked INLINE to expose the underlying primops to the simplifier; see Note [INLINE for constant folding of bit operations]. This restores folding only on the small-int (IS) path -- large literal Integers (IP/IN) are no longer constant-folded, a minor regression for that case. T8832 covers the IS-path folding. The new golden-output test T21176 checks all three operations against the default implementations across the sign/size boundaries, recording each result plus its integerCheck validity. The base and ghc-bignum interface- stability export goldens gain the new functions. The main changelog entry lives in changelog.d under a new ghc-internal section (renamed from ghc-prim). Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - 21 changed files: - boot - + changelog.d/T21176 - changelog.d/config - hadrian/src/Hadrian/Oracles/Path.hs - hadrian/src/Rules/BinaryDist.hs - libraries/base/changelog.md - libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs - libraries/ghc-internal/src/GHC/Internal/Bits.hs - testsuite/driver/runtests.py - testsuite/mk/test.mk - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-bignum-exports.stdout - + testsuite/tests/numeric/should_run/T21176.hs - + testsuite/tests/numeric/should_run/T21176.stdout - testsuite/tests/numeric/should_run/all.T - testsuite/tests/simplCore/should_compile/T8832.hs - testsuite/tests/simplCore/should_compile/T8832.stdout - utils/check-exact/Main.hs - utils/check-exact/Transform.hs Changes: ===================================== boot ===================================== @@ -52,9 +52,8 @@ def autoreconf(): # Run autoreconf on everything that needs it. processes = {} if os.name == 'nt': - # Get the normalized ACLOCAL_PATH for Windows - # This is necessary since on Windows this will be a Windows - # path, which autoreconf doesn't know doesn't know how to handle. + # Convert ACLOCAL_PATH env variable to unix style paths on Windows + # See Note [Autoreconf unix paths from ACLOCAL_PATH] ac_local = os.getenv('ACLOCAL_PATH', '') ac_local_arg = re.sub(r';', r':', ac_local) ac_local_arg = re.sub(r'\\', r'/', ac_local_arg) ===================================== changelog.d/T21176 ===================================== @@ -0,0 +1,4 @@ +section: ghc-internal +synopsis: Give ``setBit``, ``clearBit`` and ``complementBit`` explicit definitions in ``instance Bits Integer``, backed by new ``integerSetBit[#]``, ``integerClearBit[#]`` and ``integerComplementBit[#]`` functions. These avoid the intermediate ``Integer`` allocations of the previous default methods, although allocation is not eliminated entirely — notably the negative (``IN``) cases would require in-place mutation, which is left as future work. As a trade-off, constant folding of these operations now applies only to small (machine-word-sized) literal arguments; the previous default methods folded literal ``Integer`` arguments of any size via the ``integerOr``/``integerAnd``/``integerXor`` rules. +issues: #21176 +mrs: !7772 ===================================== changelog.d/config ===================================== @@ -27,7 +27,7 @@ sections: { cmm Cmm build-tools Build tools base ``base`` library - ghc-prim ``ghc-prim`` library + ghc-internal ``ghc-internal`` library ghc-lib ``ghc`` library ghc-heap ``ghc-heap`` library ghc-experimental ``ghc-experimental`` library ===================================== hadrian/src/Hadrian/Oracles/Path.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} module Hadrian.Oracles.Path ( - lookupInPath, fixAbsolutePathOnWindows, pathOracle + lookupInPath, fixAbsolutePathOnWindows, fixUnixPathsOnWindows, + pathOracle ) where import Control.Monad @@ -33,6 +34,14 @@ fixAbsolutePathOnWindows path = else return path +-- | Fix a unix path list on Windows: +-- * "C:\\foo\\bar;C:\\msys2\\bin" => "/c/foo/bar:/c/msys2/bin" +fixUnixPathsOnWindows :: FilePath -> Action FilePath +fixUnixPathsOnWindows paths = + if isWindows + then askOracle $ UnixPathList paths + else return paths + newtype LookupInPath = LookupInPath String deriving (Binary, Eq, Hashable, NFData, Show) type instance RuleResult LookupInPath = String @@ -41,6 +50,10 @@ newtype WindowsPath = WindowsPath FilePath deriving (Binary, Eq, Hashable, NFData, Show) type instance RuleResult WindowsPath = String +newtype UnixPathList = UnixPathList FilePath + deriving (Binary, Eq, Hashable, NFData, Show) +type instance RuleResult UnixPathList = String + -- | Oracles for looking up paths. These are slow and require caching. pathOracle :: Rules () pathOracle = do @@ -50,6 +63,12 @@ pathOracle = do putVerbose $ "| Windows path mapping: " ++ path ++ " => " ++ windowsPath return windowsPath + void $ addOracleCache $ \(UnixPathList paths) -> do + Stdout out <- quietly $ cmd ["cygpath", "-p", "-u", paths] + let unixPaths = unifyPath $ dropWhileEnd isSpace out + putVerbose $ "| Unix path mapping: " ++ paths ++ " => " ++ unixPaths + return unixPaths + void $ addOracleCache $ \(LookupInPath name) -> do path <- liftIO getSearchPath exes <- liftIO (findExecutablesInDirectories path name) ===================================== hadrian/src/Rules/BinaryDist.hs ===================================== @@ -3,18 +3,19 @@ module Rules.BinaryDist where import CommandLine import Context +import Data.Either +import qualified Data.Set as Set import Expression +import Hadrian.Oracles.Path (fixUnixPathsOnWindows) +import Oracles.Flavour import Oracles.Setting import Packages +import Rules.Generate (generateSettings) import Settings +import qualified System.Directory.Extra as IO import Settings.Program (programContext) import Target import Utilities -import qualified System.Directory.Extra as IO -import Data.Either -import qualified Data.Set as Set -import Oracles.Flavour -import Rules.Generate (generateSettings) {- Note [Binary distributions] @@ -343,7 +344,25 @@ bindistRules = do ghcRoot <- topDirectory copyFile (ghcRoot -/- "aclocal.m4") (ghcRoot -/- "distrib" -/- "aclocal.m4") copyDirectory (ghcRoot -/- "m4") (ghcRoot -/- "distrib") - buildWithCmdOptions [] $ + + -- Note [Autoreconf unix paths from ACLOCAL_PATH] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- On Windows, autoreconf fails when the ACLOCAL_PATH env variable contains Windows- + -- style paths. This happens because MSYS2 automatically converts env variables to + -- Windows-style paths. To fix this, we convert ACLOCAL_PATH back to Unix style. + -- This is done both in the boot Python script and here when building a bindist. + win_host <- isWinHost + env <- if not win_host + then pure [] + else do + aclocalPathMay <- getEnv "ACLOCAL_PATH" + case aclocalPathMay of + Nothing -> pure [] + Just aclocalPath -> do + unixAclocalPath <- fixUnixPathsOnWindows aclocalPath + pure [AddEnv "ACLOCAL_PATH" unixAclocalPath] + + buildWithCmdOptions env $ target (vanillaContext Stage1 ghc) (Autoreconf $ ghcRoot -/- "distrib") [] [] -- We clean after ourselves, moving the configure script we generated in -- our bindist dir ===================================== libraries/base/changelog.md ===================================== @@ -1,6 +1,7 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) ## 4.24.0.0 *TBA* + * Give `setBit`, `clearBit` and `complementBit` explicit definitions in `instance Bits Integer`, reducing intermediate allocations. ([GHC #21176](https://gitlab.haskell.org/ghc/ghc/-/issues/21176)) * Add `Bounded` instances for `Double`, `Float`, `CDouble` and `CFloat`. ([CLC proposal #402](https://github.com/haskell/core-libraries-committee/issues/402)) * Ensure that `Data.List.elem` and `notElem` can be specialized even when no list fusion happens. ([CLC proposal #412)(https://github.com/haskell/core-libraries-committee/issues/412)) ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs ===================================== @@ -133,6 +133,12 @@ module GHC.Internal.Bignum.Integer , integerBit , integerTestBit# , integerTestBit + , integerSetBit# + , integerSetBit + , integerClearBit# + , integerClearBit + , integerComplementBit# + , integerComplementBit , integerShiftR# , integerShiftR , integerShiftL# @@ -707,6 +713,113 @@ integerTestBit# (IN x) i integerTestBit :: Integer -> Word -> Bool integerTestBit !i (W# n) = isTrue# (integerTestBit# i n) +{- Note [INLINE for constant folding of bit operations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While there are no dedicated constant-folding rules for +integerSetBit#/integerClearBit#/integerComplementBit#, we do INLINE them (and +their Word-argument wrappers and the corresponding Bits Integer methods) to make +the underlying primops accessible for constant folding, e.g. so that +`clearBit (bit 0) 0 :: Integer` folds to `IS 0#`. Test T8832 checks the folding +for all three operations. +-} + +-- | Set the /n/-th bit. +-- +-- Fake 2's complement for negative values (might be slow) +-- +-- @since 10.201.0 +integerSetBit# :: Integer -> Word# -> Integer +{-# INLINE integerSetBit# #-} -- See Note [INLINE for constant folding of bit operations] +integerSetBit# n@(IS x) i + | isTrue# (i `ltWord#` (WORD_SIZE_IN_BITS## `minusWord#` 1##)) + = IS (x `orI#` uncheckedIShiftL# 1# (word2Int# i)) + | isTrue# (x >=# 0#) + = IP (bigNatSetBit# (bigNatFromWord# (int2Word# x)) i) + | True + = n +integerSetBit# (IP x) i = IP (bigNatSetBit# x i) +integerSetBit# (IN x) i = integerFromBigNatNeg# + (bigNatAddWord# + (bigNatClearBit# (bigNatSubWordUnsafe# x 1##) i) + 1##) + +-- | Set the /n/-th bit. +-- +-- Fake 2's complement for negative values (might be slow) +-- +-- @since 10.201.0 +integerSetBit :: Integer -> Word -> Integer +{-# INLINE integerSetBit #-} -- See Note [INLINE for constant folding of bit operations] +integerSetBit !i (W# n) = integerSetBit# i n + +-- | Clear the /n/-th bit. +-- +-- Fake 2's complement for negative values (might be slow) +-- +-- @since 10.201.0 +integerClearBit# :: Integer -> Word# -> Integer +{-# INLINE integerClearBit# #-} -- See Note [INLINE for constant folding of bit operations] +integerClearBit# n@(IS x) i + | isTrue# (i `ltWord#` (WORD_SIZE_IN_BITS## `minusWord#` 1##)) + = IS (x `andI#` notI# (uncheckedIShiftL# 1# (word2Int# i))) + | isTrue# (x >=# 0#) + = n + | True + = IN (bigNatAddWord# + (bigNatSetBit# + (bigNatFromWord# + (minusWord# (int2Word# (negateInt# x)) 1##)) + i) + 1##) +integerClearBit# (IP x) i = integerFromBigNat# (bigNatClearBit# x i) +integerClearBit# (IN x) i = IN (bigNatAddWord# + (bigNatSetBit# (bigNatSubWordUnsafe# x 1##) i) + 1##) + +-- | Clear the /n/-th bit. +-- +-- Fake 2's complement for negative values (might be slow) +-- +-- @since 10.201.0 +integerClearBit :: Integer -> Word -> Integer +{-# INLINE integerClearBit #-} -- See Note [INLINE for constant folding of bit operations] +integerClearBit !i (W# n) = integerClearBit# i n + +-- | Reverse the /n/-th bit. +-- +-- Fake 2's complement for negative values (might be slow) +-- +-- @since 10.201.0 +integerComplementBit# :: Integer -> Word# -> Integer +{-# INLINE integerComplementBit# #-} -- See Note [INLINE for constant folding of bit operations] +integerComplementBit# (IS x) i + | isTrue# (i `ltWord#` (WORD_SIZE_IN_BITS## `minusWord#` 1##)) + = IS (x `xorI#` uncheckedIShiftL# 1# (word2Int# i)) + | isTrue# (x >=# 0#) + = IP (bigNatSetBit# (bigNatFromWord# (int2Word# x)) i) + | True + = IN (bigNatAddWord# + (bigNatSetBit# + (bigNatFromWord# (minusWord# (int2Word# (negateInt# x)) 1##)) + i) + 1##) +integerComplementBit# (IP x) i = integerFromBigNat# (bigNatComplementBit# x i) +integerComplementBit# (IN x) i = integerFromBigNatNeg# + (bigNatAddWord# + (bigNatComplementBit# + (bigNatSubWordUnsafe# x 1##) + i) + 1##) + +-- | Reverse the /n/-th bit. +-- +-- Fake 2's complement for negative values (might be slow) +-- +-- @since 10.201.0 +integerComplementBit :: Integer -> Word -> Integer +{-# INLINE integerComplementBit #-} -- See Note [INLINE for constant folding of bit operations] +integerComplementBit !i (W# n) = integerComplementBit# i n + -- | Shift-right operation -- -- Fake 2's complement for negative values (might be slow) ===================================== libraries/ghc-internal/src/GHC/Internal/Bits.hs ===================================== @@ -564,6 +564,15 @@ instance Bits Integer where | otherwise = integerShiftR x (fromIntegral (negate i)) testBit x i = integerTestBit x (fromIntegral i) zeroBits = integerZero + -- INLINE on setBit/clearBit/complementBit preserves constant folding; + -- see Note [INLINE for constant folding of bit operations] in + -- GHC.Internal.Bignum.Integer. + setBit x i = integerSetBit x (fromIntegral i) + {-# INLINE setBit #-} + clearBit x i = integerClearBit x (fromIntegral i) + {-# INLINE clearBit #-} + complementBit x i = integerComplementBit x (fromIntegral i) + {-# INLINE complementBit #-} bit (I# i) = integerBit# (int2Word# i) popCount x = I# (integerPopCount# x) ===================================== testsuite/driver/runtests.py ===================================== @@ -133,7 +133,7 @@ if args.unexpected_output_dir: config.unexpected_output_dir = Path(args.unexpected_output_dir) if args.only: - config.only = args.only + config.only = set(args.only) config.run_only_some_tests = True if args.skip: ===================================== testsuite/mk/test.mk ===================================== @@ -109,9 +109,11 @@ endif HAVE_GDB := $(shell if gdb --version > /dev/null 2> /dev/null; then echo YES; else echo NO; fi) HAVE_READELF := $(shell if readelf --version > /dev/null 2> /dev/null; then echo YES; else echo NO; fi) -# we need a better way to find which backend is selected and if --check flag is -# used -BIGNUM_GMP := $(shell "$(GHC_PKG)" field ghc-bignum exposed-modules | grep GMP) +# Detect whether the fast (GMP) bignum backend is in use. The GMP backend module +# in ghc-internal is hidden, so we look instead for the gmp library it links +# against: GMP_LIBS adds gmp to ghc-internal's extra-libraries only on a GMP +# build. +BIGNUM_GMP := $(shell "$(GHC_PKG)" field ghc-internal extra-libraries 2>/dev/null | grep gmp) ifeq "$(filter thr, $(GhcRTSWays))" "thr" RUNTEST_OPTS += -e config.ghc_with_threaded_rts=True ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -8371,8 +8371,12 @@ module GHC.Num where integerBit# :: GHC.Internal.Prim.Word# -> Integer integerCheck :: Integer -> GHC.Internal.Types.Bool integerCheck# :: Integer -> GHC.Internal.Bignum.Primitives.Bool# + integerClearBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerClearBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerCompare :: Integer -> Integer -> GHC.Internal.Types.Ordering integerComplement :: Integer -> Integer + integerComplementBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerComplementBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerDecodeDouble# :: GHC.Internal.Prim.Double# -> (# Integer, GHC.Internal.Prim.Int# #) integerDiv :: Integer -> Integer -> Integer integerDivMod :: Integer -> Integer -> (Integer, Integer) @@ -8436,6 +8440,8 @@ module GHC.Num where integerQuotRem# :: Integer -> Integer -> (# Integer, Integer #) integerRecipMod# :: Integer -> Natural -> (# Natural | () #) integerRem :: Integer -> Integer -> Integer + integerSetBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerSetBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftL :: Integer -> GHC.Internal.Types.Word -> Integer integerShiftL# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftR :: Integer -> GHC.Internal.Types.Word -> Integer ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -8409,8 +8409,12 @@ module GHC.Num where integerBit# :: GHC.Internal.Prim.Word# -> Integer integerCheck :: Integer -> GHC.Internal.Types.Bool integerCheck# :: Integer -> GHC.Internal.Bignum.Primitives.Bool# + integerClearBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerClearBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerCompare :: Integer -> Integer -> GHC.Internal.Types.Ordering integerComplement :: Integer -> Integer + integerComplementBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerComplementBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerDecodeDouble# :: GHC.Internal.Prim.Double# -> (# Integer, GHC.Internal.Prim.Int# #) integerDiv :: Integer -> Integer -> Integer integerDivMod :: Integer -> Integer -> (Integer, Integer) @@ -8474,6 +8478,8 @@ module GHC.Num where integerQuotRem# :: Integer -> Integer -> (# Integer, Integer #) integerRecipMod# :: Integer -> Natural -> (# Natural | () #) integerRem :: Integer -> Integer -> Integer + integerSetBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerSetBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftL :: Integer -> GHC.Internal.Types.Word -> Integer integerShiftL# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftR :: Integer -> GHC.Internal.Types.Word -> Integer ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -8589,8 +8589,12 @@ module GHC.Num where integerBit# :: GHC.Internal.Prim.Word# -> Integer integerCheck :: Integer -> GHC.Internal.Types.Bool integerCheck# :: Integer -> GHC.Internal.Bignum.Primitives.Bool# + integerClearBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerClearBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerCompare :: Integer -> Integer -> GHC.Internal.Types.Ordering integerComplement :: Integer -> Integer + integerComplementBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerComplementBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerDecodeDouble# :: GHC.Internal.Prim.Double# -> (# Integer, GHC.Internal.Prim.Int# #) integerDiv :: Integer -> Integer -> Integer integerDivMod :: Integer -> Integer -> (Integer, Integer) @@ -8654,6 +8658,8 @@ module GHC.Num where integerQuotRem# :: Integer -> Integer -> (# Integer, Integer #) integerRecipMod# :: Integer -> Natural -> (# Natural | () #) integerRem :: Integer -> Integer -> Integer + integerSetBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerSetBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftL :: Integer -> GHC.Internal.Types.Word -> Integer integerShiftL# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftR :: Integer -> GHC.Internal.Types.Word -> Integer ===================================== testsuite/tests/interface-stability/ghc-bignum-exports.stdout ===================================== @@ -201,8 +201,12 @@ module GHC.Num.Integer where integerBit# :: GHC.Internal.Prim.Word# -> Integer integerCheck :: Integer -> GHC.Internal.Types.Bool integerCheck# :: Integer -> GHC.Internal.Bignum.Primitives.Bool# + integerClearBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerClearBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerCompare :: Integer -> Integer -> GHC.Internal.Types.Ordering integerComplement :: Integer -> Integer + integerComplementBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerComplementBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerDecodeDouble# :: GHC.Internal.Prim.Double# -> (# Integer, GHC.Internal.Prim.Int# #) integerDiv :: Integer -> Integer -> Integer integerDivMod :: Integer -> Integer -> (Integer, Integer) @@ -266,6 +270,8 @@ module GHC.Num.Integer where integerQuotRem# :: Integer -> Integer -> (# Integer, Integer #) integerRecipMod# :: Integer -> GHC.Internal.Bignum.Natural.Natural -> (# GHC.Internal.Bignum.Natural.Natural | () #) integerRem :: Integer -> Integer -> Integer + integerSetBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerSetBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftL :: Integer -> GHC.Internal.Types.Word -> Integer integerShiftL# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftR :: Integer -> GHC.Internal.Types.Word -> Integer ===================================== testsuite/tests/numeric/should_run/T21176.hs ===================================== @@ -0,0 +1,37 @@ +module Main where + +import Data.Bits +import Data.Int (Int32, Int64) +import Data.Foldable (for_) +import GHC.Num.Integer (integerCheck) + +integers :: [Integer] +integers = concatMap neighbours [minInt64, minInt32, 0, maxInt32, maxInt64] + where + neighbours i = [i - 2, i - 1, i, i + 1, i + 2] + minInt64 = toInteger (minBound :: Int64) + minInt32 = toInteger (minBound :: Int32) + maxInt32 = toInteger (maxBound :: Int32) + maxInt64 = toInteger (maxBound :: Int64) + +bits :: [Int] +bits = [0, 1, 62, 63, 64] + +testXBit :: String -> (Integer -> Int -> Integer) -> (Integer -> Int -> Integer) -> IO () +testXBit name f model = do + putStrLn name + for_ integers $ \i -> + for_ bits $ \b -> do + let actual = f i b + expected = model i b + valid = if integerCheck actual then "valid" else "invalid" + matches = if actual == expected then "matches" else "differs" + putStrLn $ " " ++ show i ++ " " ++ show b ++ " -> " ++ show actual + ++ " [" ++ valid ++ ", " ++ matches ++ "]" + putStrLn "" + +main :: IO () +main = do + testXBit "setBit" setBit (\i b -> i .|. bit b) + testXBit "clearBit" clearBit (\i b -> i .&. complement (bit b)) + testXBit "complementBit" complementBit (\i b -> i `xor` bit b) ===================================== testsuite/tests/numeric/should_run/T21176.stdout ===================================== @@ -0,0 +1,381 @@ +setBit + -9223372036854775810 0 -> -9223372036854775809 [valid, matches] + -9223372036854775810 1 -> -9223372036854775810 [valid, matches] + -9223372036854775810 62 -> -9223372036854775810 [valid, matches] + -9223372036854775810 63 -> -2 [valid, matches] + -9223372036854775810 64 -> -9223372036854775810 [valid, matches] + -9223372036854775809 0 -> -9223372036854775809 [valid, matches] + -9223372036854775809 1 -> -9223372036854775809 [valid, matches] + -9223372036854775809 62 -> -9223372036854775809 [valid, matches] + -9223372036854775809 63 -> -1 [valid, matches] + -9223372036854775809 64 -> -9223372036854775809 [valid, matches] + -9223372036854775808 0 -> -9223372036854775807 [valid, matches] + -9223372036854775808 1 -> -9223372036854775806 [valid, matches] + -9223372036854775808 62 -> -4611686018427387904 [valid, matches] + -9223372036854775808 63 -> -9223372036854775808 [valid, matches] + -9223372036854775808 64 -> -9223372036854775808 [valid, matches] + -9223372036854775807 0 -> -9223372036854775807 [valid, matches] + -9223372036854775807 1 -> -9223372036854775805 [valid, matches] + -9223372036854775807 62 -> -4611686018427387903 [valid, matches] + -9223372036854775807 63 -> -9223372036854775807 [valid, matches] + -9223372036854775807 64 -> -9223372036854775807 [valid, matches] + -9223372036854775806 0 -> -9223372036854775805 [valid, matches] + -9223372036854775806 1 -> -9223372036854775806 [valid, matches] + -9223372036854775806 62 -> -4611686018427387902 [valid, matches] + -9223372036854775806 63 -> -9223372036854775806 [valid, matches] + -9223372036854775806 64 -> -9223372036854775806 [valid, matches] + -2147483650 0 -> -2147483649 [valid, matches] + -2147483650 1 -> -2147483650 [valid, matches] + -2147483650 62 -> -2147483650 [valid, matches] + -2147483650 63 -> -2147483650 [valid, matches] + -2147483650 64 -> -2147483650 [valid, matches] + -2147483649 0 -> -2147483649 [valid, matches] + -2147483649 1 -> -2147483649 [valid, matches] + -2147483649 62 -> -2147483649 [valid, matches] + -2147483649 63 -> -2147483649 [valid, matches] + -2147483649 64 -> -2147483649 [valid, matches] + -2147483648 0 -> -2147483647 [valid, matches] + -2147483648 1 -> -2147483646 [valid, matches] + -2147483648 62 -> -2147483648 [valid, matches] + -2147483648 63 -> -2147483648 [valid, matches] + -2147483648 64 -> -2147483648 [valid, matches] + -2147483647 0 -> -2147483647 [valid, matches] + -2147483647 1 -> -2147483645 [valid, matches] + -2147483647 62 -> -2147483647 [valid, matches] + -2147483647 63 -> -2147483647 [valid, matches] + -2147483647 64 -> -2147483647 [valid, matches] + -2147483646 0 -> -2147483645 [valid, matches] + -2147483646 1 -> -2147483646 [valid, matches] + -2147483646 62 -> -2147483646 [valid, matches] + -2147483646 63 -> -2147483646 [valid, matches] + -2147483646 64 -> -2147483646 [valid, matches] + -2 0 -> -1 [valid, matches] + -2 1 -> -2 [valid, matches] + -2 62 -> -2 [valid, matches] + -2 63 -> -2 [valid, matches] + -2 64 -> -2 [valid, matches] + -1 0 -> -1 [valid, matches] + -1 1 -> -1 [valid, matches] + -1 62 -> -1 [valid, matches] + -1 63 -> -1 [valid, matches] + -1 64 -> -1 [valid, matches] + 0 0 -> 1 [valid, matches] + 0 1 -> 2 [valid, matches] + 0 62 -> 4611686018427387904 [valid, matches] + 0 63 -> 9223372036854775808 [valid, matches] + 0 64 -> 18446744073709551616 [valid, matches] + 1 0 -> 1 [valid, matches] + 1 1 -> 3 [valid, matches] + 1 62 -> 4611686018427387905 [valid, matches] + 1 63 -> 9223372036854775809 [valid, matches] + 1 64 -> 18446744073709551617 [valid, matches] + 2 0 -> 3 [valid, matches] + 2 1 -> 2 [valid, matches] + 2 62 -> 4611686018427387906 [valid, matches] + 2 63 -> 9223372036854775810 [valid, matches] + 2 64 -> 18446744073709551618 [valid, matches] + 2147483645 0 -> 2147483645 [valid, matches] + 2147483645 1 -> 2147483647 [valid, matches] + 2147483645 62 -> 4611686020574871549 [valid, matches] + 2147483645 63 -> 9223372039002259453 [valid, matches] + 2147483645 64 -> 18446744075857035261 [valid, matches] + 2147483646 0 -> 2147483647 [valid, matches] + 2147483646 1 -> 2147483646 [valid, matches] + 2147483646 62 -> 4611686020574871550 [valid, matches] + 2147483646 63 -> 9223372039002259454 [valid, matches] + 2147483646 64 -> 18446744075857035262 [valid, matches] + 2147483647 0 -> 2147483647 [valid, matches] + 2147483647 1 -> 2147483647 [valid, matches] + 2147483647 62 -> 4611686020574871551 [valid, matches] + 2147483647 63 -> 9223372039002259455 [valid, matches] + 2147483647 64 -> 18446744075857035263 [valid, matches] + 2147483648 0 -> 2147483649 [valid, matches] + 2147483648 1 -> 2147483650 [valid, matches] + 2147483648 62 -> 4611686020574871552 [valid, matches] + 2147483648 63 -> 9223372039002259456 [valid, matches] + 2147483648 64 -> 18446744075857035264 [valid, matches] + 2147483649 0 -> 2147483649 [valid, matches] + 2147483649 1 -> 2147483651 [valid, matches] + 2147483649 62 -> 4611686020574871553 [valid, matches] + 2147483649 63 -> 9223372039002259457 [valid, matches] + 2147483649 64 -> 18446744075857035265 [valid, matches] + 9223372036854775805 0 -> 9223372036854775805 [valid, matches] + 9223372036854775805 1 -> 9223372036854775807 [valid, matches] + 9223372036854775805 62 -> 9223372036854775805 [valid, matches] + 9223372036854775805 63 -> 18446744073709551613 [valid, matches] + 9223372036854775805 64 -> 27670116110564327421 [valid, matches] + 9223372036854775806 0 -> 9223372036854775807 [valid, matches] + 9223372036854775806 1 -> 9223372036854775806 [valid, matches] + 9223372036854775806 62 -> 9223372036854775806 [valid, matches] + 9223372036854775806 63 -> 18446744073709551614 [valid, matches] + 9223372036854775806 64 -> 27670116110564327422 [valid, matches] + 9223372036854775807 0 -> 9223372036854775807 [valid, matches] + 9223372036854775807 1 -> 9223372036854775807 [valid, matches] + 9223372036854775807 62 -> 9223372036854775807 [valid, matches] + 9223372036854775807 63 -> 18446744073709551615 [valid, matches] + 9223372036854775807 64 -> 27670116110564327423 [valid, matches] + 9223372036854775808 0 -> 9223372036854775809 [valid, matches] + 9223372036854775808 1 -> 9223372036854775810 [valid, matches] + 9223372036854775808 62 -> 13835058055282163712 [valid, matches] + 9223372036854775808 63 -> 9223372036854775808 [valid, matches] + 9223372036854775808 64 -> 27670116110564327424 [valid, matches] + 9223372036854775809 0 -> 9223372036854775809 [valid, matches] + 9223372036854775809 1 -> 9223372036854775811 [valid, matches] + 9223372036854775809 62 -> 13835058055282163713 [valid, matches] + 9223372036854775809 63 -> 9223372036854775809 [valid, matches] + 9223372036854775809 64 -> 27670116110564327425 [valid, matches] + +clearBit + -9223372036854775810 0 -> -9223372036854775810 [valid, matches] + -9223372036854775810 1 -> -9223372036854775812 [valid, matches] + -9223372036854775810 62 -> -13835058055282163714 [valid, matches] + -9223372036854775810 63 -> -9223372036854775810 [valid, matches] + -9223372036854775810 64 -> -27670116110564327426 [valid, matches] + -9223372036854775809 0 -> -9223372036854775810 [valid, matches] + -9223372036854775809 1 -> -9223372036854775811 [valid, matches] + -9223372036854775809 62 -> -13835058055282163713 [valid, matches] + -9223372036854775809 63 -> -9223372036854775809 [valid, matches] + -9223372036854775809 64 -> -27670116110564327425 [valid, matches] + -9223372036854775808 0 -> -9223372036854775808 [valid, matches] + -9223372036854775808 1 -> -9223372036854775808 [valid, matches] + -9223372036854775808 62 -> -9223372036854775808 [valid, matches] + -9223372036854775808 63 -> -18446744073709551616 [valid, matches] + -9223372036854775808 64 -> -27670116110564327424 [valid, matches] + -9223372036854775807 0 -> -9223372036854775808 [valid, matches] + -9223372036854775807 1 -> -9223372036854775807 [valid, matches] + -9223372036854775807 62 -> -9223372036854775807 [valid, matches] + -9223372036854775807 63 -> -18446744073709551615 [valid, matches] + -9223372036854775807 64 -> -27670116110564327423 [valid, matches] + -9223372036854775806 0 -> -9223372036854775806 [valid, matches] + -9223372036854775806 1 -> -9223372036854775808 [valid, matches] + -9223372036854775806 62 -> -9223372036854775806 [valid, matches] + -9223372036854775806 63 -> -18446744073709551614 [valid, matches] + -9223372036854775806 64 -> -27670116110564327422 [valid, matches] + -2147483650 0 -> -2147483650 [valid, matches] + -2147483650 1 -> -2147483652 [valid, matches] + -2147483650 62 -> -4611686020574871554 [valid, matches] + -2147483650 63 -> -9223372039002259458 [valid, matches] + -2147483650 64 -> -18446744075857035266 [valid, matches] + -2147483649 0 -> -2147483650 [valid, matches] + -2147483649 1 -> -2147483651 [valid, matches] + -2147483649 62 -> -4611686020574871553 [valid, matches] + -2147483649 63 -> -9223372039002259457 [valid, matches] + -2147483649 64 -> -18446744075857035265 [valid, matches] + -2147483648 0 -> -2147483648 [valid, matches] + -2147483648 1 -> -2147483648 [valid, matches] + -2147483648 62 -> -4611686020574871552 [valid, matches] + -2147483648 63 -> -9223372039002259456 [valid, matches] + -2147483648 64 -> -18446744075857035264 [valid, matches] + -2147483647 0 -> -2147483648 [valid, matches] + -2147483647 1 -> -2147483647 [valid, matches] + -2147483647 62 -> -4611686020574871551 [valid, matches] + -2147483647 63 -> -9223372039002259455 [valid, matches] + -2147483647 64 -> -18446744075857035263 [valid, matches] + -2147483646 0 -> -2147483646 [valid, matches] + -2147483646 1 -> -2147483648 [valid, matches] + -2147483646 62 -> -4611686020574871550 [valid, matches] + -2147483646 63 -> -9223372039002259454 [valid, matches] + -2147483646 64 -> -18446744075857035262 [valid, matches] + -2 0 -> -2 [valid, matches] + -2 1 -> -4 [valid, matches] + -2 62 -> -4611686018427387906 [valid, matches] + -2 63 -> -9223372036854775810 [valid, matches] + -2 64 -> -18446744073709551618 [valid, matches] + -1 0 -> -2 [valid, matches] + -1 1 -> -3 [valid, matches] + -1 62 -> -4611686018427387905 [valid, matches] + -1 63 -> -9223372036854775809 [valid, matches] + -1 64 -> -18446744073709551617 [valid, matches] + 0 0 -> 0 [valid, matches] + 0 1 -> 0 [valid, matches] + 0 62 -> 0 [valid, matches] + 0 63 -> 0 [valid, matches] + 0 64 -> 0 [valid, matches] + 1 0 -> 0 [valid, matches] + 1 1 -> 1 [valid, matches] + 1 62 -> 1 [valid, matches] + 1 63 -> 1 [valid, matches] + 1 64 -> 1 [valid, matches] + 2 0 -> 2 [valid, matches] + 2 1 -> 0 [valid, matches] + 2 62 -> 2 [valid, matches] + 2 63 -> 2 [valid, matches] + 2 64 -> 2 [valid, matches] + 2147483645 0 -> 2147483644 [valid, matches] + 2147483645 1 -> 2147483645 [valid, matches] + 2147483645 62 -> 2147483645 [valid, matches] + 2147483645 63 -> 2147483645 [valid, matches] + 2147483645 64 -> 2147483645 [valid, matches] + 2147483646 0 -> 2147483646 [valid, matches] + 2147483646 1 -> 2147483644 [valid, matches] + 2147483646 62 -> 2147483646 [valid, matches] + 2147483646 63 -> 2147483646 [valid, matches] + 2147483646 64 -> 2147483646 [valid, matches] + 2147483647 0 -> 2147483646 [valid, matches] + 2147483647 1 -> 2147483645 [valid, matches] + 2147483647 62 -> 2147483647 [valid, matches] + 2147483647 63 -> 2147483647 [valid, matches] + 2147483647 64 -> 2147483647 [valid, matches] + 2147483648 0 -> 2147483648 [valid, matches] + 2147483648 1 -> 2147483648 [valid, matches] + 2147483648 62 -> 2147483648 [valid, matches] + 2147483648 63 -> 2147483648 [valid, matches] + 2147483648 64 -> 2147483648 [valid, matches] + 2147483649 0 -> 2147483648 [valid, matches] + 2147483649 1 -> 2147483649 [valid, matches] + 2147483649 62 -> 2147483649 [valid, matches] + 2147483649 63 -> 2147483649 [valid, matches] + 2147483649 64 -> 2147483649 [valid, matches] + 9223372036854775805 0 -> 9223372036854775804 [valid, matches] + 9223372036854775805 1 -> 9223372036854775805 [valid, matches] + 9223372036854775805 62 -> 4611686018427387901 [valid, matches] + 9223372036854775805 63 -> 9223372036854775805 [valid, matches] + 9223372036854775805 64 -> 9223372036854775805 [valid, matches] + 9223372036854775806 0 -> 9223372036854775806 [valid, matches] + 9223372036854775806 1 -> 9223372036854775804 [valid, matches] + 9223372036854775806 62 -> 4611686018427387902 [valid, matches] + 9223372036854775806 63 -> 9223372036854775806 [valid, matches] + 9223372036854775806 64 -> 9223372036854775806 [valid, matches] + 9223372036854775807 0 -> 9223372036854775806 [valid, matches] + 9223372036854775807 1 -> 9223372036854775805 [valid, matches] + 9223372036854775807 62 -> 4611686018427387903 [valid, matches] + 9223372036854775807 63 -> 9223372036854775807 [valid, matches] + 9223372036854775807 64 -> 9223372036854775807 [valid, matches] + 9223372036854775808 0 -> 9223372036854775808 [valid, matches] + 9223372036854775808 1 -> 9223372036854775808 [valid, matches] + 9223372036854775808 62 -> 9223372036854775808 [valid, matches] + 9223372036854775808 63 -> 0 [valid, matches] + 9223372036854775808 64 -> 9223372036854775808 [valid, matches] + 9223372036854775809 0 -> 9223372036854775808 [valid, matches] + 9223372036854775809 1 -> 9223372036854775809 [valid, matches] + 9223372036854775809 62 -> 9223372036854775809 [valid, matches] + 9223372036854775809 63 -> 1 [valid, matches] + 9223372036854775809 64 -> 9223372036854775809 [valid, matches] + +complementBit + -9223372036854775810 0 -> -9223372036854775809 [valid, matches] + -9223372036854775810 1 -> -9223372036854775812 [valid, matches] + -9223372036854775810 62 -> -13835058055282163714 [valid, matches] + -9223372036854775810 63 -> -2 [valid, matches] + -9223372036854775810 64 -> -27670116110564327426 [valid, matches] + -9223372036854775809 0 -> -9223372036854775810 [valid, matches] + -9223372036854775809 1 -> -9223372036854775811 [valid, matches] + -9223372036854775809 62 -> -13835058055282163713 [valid, matches] + -9223372036854775809 63 -> -1 [valid, matches] + -9223372036854775809 64 -> -27670116110564327425 [valid, matches] + -9223372036854775808 0 -> -9223372036854775807 [valid, matches] + -9223372036854775808 1 -> -9223372036854775806 [valid, matches] + -9223372036854775808 62 -> -4611686018427387904 [valid, matches] + -9223372036854775808 63 -> -18446744073709551616 [valid, matches] + -9223372036854775808 64 -> -27670116110564327424 [valid, matches] + -9223372036854775807 0 -> -9223372036854775808 [valid, matches] + -9223372036854775807 1 -> -9223372036854775805 [valid, matches] + -9223372036854775807 62 -> -4611686018427387903 [valid, matches] + -9223372036854775807 63 -> -18446744073709551615 [valid, matches] + -9223372036854775807 64 -> -27670116110564327423 [valid, matches] + -9223372036854775806 0 -> -9223372036854775805 [valid, matches] + -9223372036854775806 1 -> -9223372036854775808 [valid, matches] + -9223372036854775806 62 -> -4611686018427387902 [valid, matches] + -9223372036854775806 63 -> -18446744073709551614 [valid, matches] + -9223372036854775806 64 -> -27670116110564327422 [valid, matches] + -2147483650 0 -> -2147483649 [valid, matches] + -2147483650 1 -> -2147483652 [valid, matches] + -2147483650 62 -> -4611686020574871554 [valid, matches] + -2147483650 63 -> -9223372039002259458 [valid, matches] + -2147483650 64 -> -18446744075857035266 [valid, matches] + -2147483649 0 -> -2147483650 [valid, matches] + -2147483649 1 -> -2147483651 [valid, matches] + -2147483649 62 -> -4611686020574871553 [valid, matches] + -2147483649 63 -> -9223372039002259457 [valid, matches] + -2147483649 64 -> -18446744075857035265 [valid, matches] + -2147483648 0 -> -2147483647 [valid, matches] + -2147483648 1 -> -2147483646 [valid, matches] + -2147483648 62 -> -4611686020574871552 [valid, matches] + -2147483648 63 -> -9223372039002259456 [valid, matches] + -2147483648 64 -> -18446744075857035264 [valid, matches] + -2147483647 0 -> -2147483648 [valid, matches] + -2147483647 1 -> -2147483645 [valid, matches] + -2147483647 62 -> -4611686020574871551 [valid, matches] + -2147483647 63 -> -9223372039002259455 [valid, matches] + -2147483647 64 -> -18446744075857035263 [valid, matches] + -2147483646 0 -> -2147483645 [valid, matches] + -2147483646 1 -> -2147483648 [valid, matches] + -2147483646 62 -> -4611686020574871550 [valid, matches] + -2147483646 63 -> -9223372039002259454 [valid, matches] + -2147483646 64 -> -18446744075857035262 [valid, matches] + -2 0 -> -1 [valid, matches] + -2 1 -> -4 [valid, matches] + -2 62 -> -4611686018427387906 [valid, matches] + -2 63 -> -9223372036854775810 [valid, matches] + -2 64 -> -18446744073709551618 [valid, matches] + -1 0 -> -2 [valid, matches] + -1 1 -> -3 [valid, matches] + -1 62 -> -4611686018427387905 [valid, matches] + -1 63 -> -9223372036854775809 [valid, matches] + -1 64 -> -18446744073709551617 [valid, matches] + 0 0 -> 1 [valid, matches] + 0 1 -> 2 [valid, matches] + 0 62 -> 4611686018427387904 [valid, matches] + 0 63 -> 9223372036854775808 [valid, matches] + 0 64 -> 18446744073709551616 [valid, matches] + 1 0 -> 0 [valid, matches] + 1 1 -> 3 [valid, matches] + 1 62 -> 4611686018427387905 [valid, matches] + 1 63 -> 9223372036854775809 [valid, matches] + 1 64 -> 18446744073709551617 [valid, matches] + 2 0 -> 3 [valid, matches] + 2 1 -> 0 [valid, matches] + 2 62 -> 4611686018427387906 [valid, matches] + 2 63 -> 9223372036854775810 [valid, matches] + 2 64 -> 18446744073709551618 [valid, matches] + 2147483645 0 -> 2147483644 [valid, matches] + 2147483645 1 -> 2147483647 [valid, matches] + 2147483645 62 -> 4611686020574871549 [valid, matches] + 2147483645 63 -> 9223372039002259453 [valid, matches] + 2147483645 64 -> 18446744075857035261 [valid, matches] + 2147483646 0 -> 2147483647 [valid, matches] + 2147483646 1 -> 2147483644 [valid, matches] + 2147483646 62 -> 4611686020574871550 [valid, matches] + 2147483646 63 -> 9223372039002259454 [valid, matches] + 2147483646 64 -> 18446744075857035262 [valid, matches] + 2147483647 0 -> 2147483646 [valid, matches] + 2147483647 1 -> 2147483645 [valid, matches] + 2147483647 62 -> 4611686020574871551 [valid, matches] + 2147483647 63 -> 9223372039002259455 [valid, matches] + 2147483647 64 -> 18446744075857035263 [valid, matches] + 2147483648 0 -> 2147483649 [valid, matches] + 2147483648 1 -> 2147483650 [valid, matches] + 2147483648 62 -> 4611686020574871552 [valid, matches] + 2147483648 63 -> 9223372039002259456 [valid, matches] + 2147483648 64 -> 18446744075857035264 [valid, matches] + 2147483649 0 -> 2147483648 [valid, matches] + 2147483649 1 -> 2147483651 [valid, matches] + 2147483649 62 -> 4611686020574871553 [valid, matches] + 2147483649 63 -> 9223372039002259457 [valid, matches] + 2147483649 64 -> 18446744075857035265 [valid, matches] + 9223372036854775805 0 -> 9223372036854775804 [valid, matches] + 9223372036854775805 1 -> 9223372036854775807 [valid, matches] + 9223372036854775805 62 -> 4611686018427387901 [valid, matches] + 9223372036854775805 63 -> 18446744073709551613 [valid, matches] + 9223372036854775805 64 -> 27670116110564327421 [valid, matches] + 9223372036854775806 0 -> 9223372036854775807 [valid, matches] + 9223372036854775806 1 -> 9223372036854775804 [valid, matches] + 9223372036854775806 62 -> 4611686018427387902 [valid, matches] + 9223372036854775806 63 -> 18446744073709551614 [valid, matches] + 9223372036854775806 64 -> 27670116110564327422 [valid, matches] + 9223372036854775807 0 -> 9223372036854775806 [valid, matches] + 9223372036854775807 1 -> 9223372036854775805 [valid, matches] + 9223372036854775807 62 -> 4611686018427387903 [valid, matches] + 9223372036854775807 63 -> 18446744073709551615 [valid, matches] + 9223372036854775807 64 -> 27670116110564327423 [valid, matches] + 9223372036854775808 0 -> 9223372036854775809 [valid, matches] + 9223372036854775808 1 -> 9223372036854775810 [valid, matches] + 9223372036854775808 62 -> 13835058055282163712 [valid, matches] + 9223372036854775808 63 -> 0 [valid, matches] + 9223372036854775808 64 -> 27670116110564327424 [valid, matches] + 9223372036854775809 0 -> 9223372036854775808 [valid, matches] + 9223372036854775809 1 -> 9223372036854775811 [valid, matches] + 9223372036854775809 62 -> 13835058055282163713 [valid, matches] + 9223372036854775809 63 -> 1 [valid, matches] + 9223372036854775809 64 -> 27670116110564327425 [valid, matches] + ===================================== testsuite/tests/numeric/should_run/all.T ===================================== @@ -101,3 +101,4 @@ test('T24245', normal, compile_and_run, ['']) test('T25653', normal, compile_and_run, ['']) test('T18619', exit_code(1), compile_and_run, ['']) test('T26230', normal, compile_and_run, ['']) +test('T21176', normal, compile_and_run, ['']) ===================================== testsuite/tests/simplCore/should_compile/T8832.hs ===================================== @@ -23,3 +23,9 @@ T(w32,Word32) T(w64,Word64) T(z,Integer) + +zset :: Integer +zset = setBit (bit 0) 0 + +zcompl :: Integer +zcompl = complementBit (bit 0) 0 ===================================== testsuite/tests/simplCore/should_compile/T8832.stdout ===================================== @@ -8,4 +8,6 @@ w8 = GHC.Internal.Word.W8# 0#Word8 w16 = GHC.Internal.Word.W16# 0#Word16 w32 = GHC.Internal.Word.W32# 0#Word32 w64 = GHC.Internal.Word.W64# 0#Word64 -z = GHC.Internal.Bignum.Integer.IS 0# +zcompl = GHC.Internal.Bignum.Integer.IS 0# +zset = GHC.Internal.Bignum.Integer.IS 1# +z = zcompl ===================================== utils/check-exact/Main.hs ===================================== @@ -646,7 +646,7 @@ addLocaLDecl3 :: Changer addLocaLDecl3 libdir top = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let - doAddLocal = replaceDecls (anchorEof lp) [parent',d2'] + doAddLocal = replaceDecls (addModuleCommentOrigDeltas lp) [parent',d2'] where lp = top (de1:d2:_) = hsDecls lp @@ -667,7 +667,7 @@ addLocaLDecl4 libdir lp = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") Right newSig <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") let - doAddLocal = replaceDecls (anchorEof lp) (parent':ds) + doAddLocal = replaceDecls (addModuleCommentOrigDeltas lp) (parent':ds) where (parent:ds) = hsDecls (makeDeltaAst lp) @@ -781,7 +781,7 @@ rmDecl3 _libdir lp = do rmDecl4 :: Changer rmDecl4 _libdir lp = do let - doRmDecl = replaceDecls (anchorEof lp) [de1',sd1] + doRmDecl = replaceDecls (addModuleCommentOrigDeltas lp) [de1',sd1] where [de1] = hsDecls lp (de1',Just sd1) = modifyValD (getLocA de1) de1 $ \_m [sd1a,sd2] -> ===================================== utils/check-exact/Transform.hs ===================================== @@ -65,7 +65,7 @@ module Transform , balanceComments , balanceCommentsList , balanceCommentsListA - , anchorEof + , addModuleCommentOrigDeltas -- ** Managing lists, pure functions , captureOrderBinds @@ -724,8 +724,8 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) -- --------------------------------------------------------------------- -anchorEof :: ParsedSource -> ParsedSource -anchorEof (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } }) +addModuleCommentOrigDeltas :: ParsedSource -> ParsedSource +addModuleCommentOrigDeltas (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } }) where an' = addCommentOrigDeltasAnn an View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ca4a699ffefb5cfc6784097a51fb73… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ca4a699ffefb5cfc6784097a51fb73… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/T21176-integer-bits] Add explicit setBit/clearBit/complementBit for instance Bits Integer (#21176)
by Simon Jakobi (＠sjakobi2) 09 Jun '26

09 Jun '26

Simon Jakobi pushed to branch wip/sjakobi/T21176-integer-bits at Glasgow Haskell Compiler / GHC Commits: 46e87880 by Simon Jakobi at 2026-06-09T14:41:55+02:00 Add explicit setBit/clearBit/complementBit for instance Bits Integer (#21176) The default setBit, clearBit, and complementBit methods allocate intermediate Integers per call. Define them explicitly via the new integerSetBit[#], integerClearBit[#] and integerComplementBit[#], built on the BigNat# primitives, which avoid those allocations. Allocation is not eliminated entirely -- the negative (IN) cases would need in-place mutation, which is left as future work. The default methods constant-folded on literal arguments via the integerOr/integerAnd/integerXor rules, which fold literal Integers of any size. The explicit functions have no such rule, so they (their Word-argument wrappers, and the Bits Integer methods) are marked INLINE to expose the underlying primops to the simplifier; see Note [INLINE for constant folding of bit operations]. This restores folding only on the small-int (IS) path -- large literal Integers (IP/IN) are no longer constant-folded, a minor regression for that case. T8832 covers the IS-path folding. The new golden-output test T21176 checks all three operations against the default implementations across the sign/size boundaries, recording each result plus its integerCheck validity. The base and ghc-bignum interface- stability export goldens gain the new functions. The main changelog entry lives in changelog.d under a new ghc-internal section (renamed from ghc-prim). Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - 14 changed files: - + changelog.d/T21176 - changelog.d/config - libraries/base/changelog.md - libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs - libraries/ghc-internal/src/GHC/Internal/Bits.hs - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-bignum-exports.stdout - + testsuite/tests/numeric/should_run/T21176.hs - + testsuite/tests/numeric/should_run/T21176.stdout - testsuite/tests/numeric/should_run/all.T - testsuite/tests/simplCore/should_compile/T8832.hs - testsuite/tests/simplCore/should_compile/T8832.stdout Changes: ===================================== changelog.d/T21176 ===================================== @@ -0,0 +1,4 @@ +section: ghc-internal +synopsis: Give ``setBit``, ``clearBit`` and ``complementBit`` explicit definitions in ``instance Bits Integer``, backed by new ``integerSetBit[#]``, ``integerClearBit[#]`` and ``integerComplementBit[#]`` functions. These avoid the intermediate ``Integer`` allocations of the previous default methods, although allocation is not eliminated entirely — notably the negative (``IN``) cases would require in-place mutation, which is left as future work. As a trade-off, constant folding of these operations now applies only to small (machine-word-sized) literal arguments; the previous default methods folded literal ``Integer`` arguments of any size via the ``integerOr``/``integerAnd``/``integerXor`` rules. +issues: #21176 +mrs: !7772 ===================================== changelog.d/config ===================================== @@ -27,7 +27,7 @@ sections: { cmm Cmm build-tools Build tools base ``base`` library - ghc-prim ``ghc-prim`` library + ghc-internal ``ghc-internal`` library ghc-lib ``ghc`` library ghc-heap ``ghc-heap`` library ghc-experimental ``ghc-experimental`` library ===================================== libraries/base/changelog.md ===================================== @@ -1,6 +1,7 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) ## 4.24.0.0 *TBA* + * Give `setBit`, `clearBit` and `complementBit` explicit definitions in `instance Bits Integer`, reducing intermediate allocations. ([GHC #21176](https://gitlab.haskell.org/ghc/ghc/-/issues/21176)) * Add `Bounded` instances for `Double`, `Float`, `CDouble` and `CFloat`. ([CLC proposal #402](https://github.com/haskell/core-libraries-committee/issues/402)) * Ensure that `Data.List.elem` and `notElem` can be specialized even when no list fusion happens. ([CLC proposal #412)(https://github.com/haskell/core-libraries-committee/issues/412)) ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs ===================================== @@ -133,6 +133,12 @@ module GHC.Internal.Bignum.Integer , integerBit , integerTestBit# , integerTestBit + , integerSetBit# + , integerSetBit + , integerClearBit# + , integerClearBit + , integerComplementBit# + , integerComplementBit , integerShiftR# , integerShiftR , integerShiftL# @@ -707,6 +713,113 @@ integerTestBit# (IN x) i integerTestBit :: Integer -> Word -> Bool integerTestBit !i (W# n) = isTrue# (integerTestBit# i n) +{- Note [INLINE for constant folding of bit operations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While there are no dedicated constant-folding rules for +integerSetBit#/integerClearBit#/integerComplementBit#, we do INLINE them (and +their Word-argument wrappers and the corresponding Bits Integer methods) to make +the underlying primops accessible for constant folding, e.g. so that +`clearBit (bit 0) 0 :: Integer` folds to `IS 0#`. Test T8832 checks the folding +for all three operations. +-} + +-- | Set the /n/-th bit. +-- +-- Fake 2's complement for negative values (might be slow) +-- +-- @since 10.201.0 +integerSetBit# :: Integer -> Word# -> Integer +{-# INLINE integerSetBit# #-} -- See Note [INLINE for constant folding of bit operations] +integerSetBit# n@(IS x) i + | isTrue# (i `ltWord#` (WORD_SIZE_IN_BITS## `minusWord#` 1##)) + = IS (x `orI#` uncheckedIShiftL# 1# (word2Int# i)) + | isTrue# (x >=# 0#) + = IP (bigNatSetBit# (bigNatFromWord# (int2Word# x)) i) + | True + = n +integerSetBit# (IP x) i = IP (bigNatSetBit# x i) +integerSetBit# (IN x) i = integerFromBigNatNeg# + (bigNatAddWord# + (bigNatClearBit# (bigNatSubWordUnsafe# x 1##) i) + 1##) + +-- | Set the /n/-th bit. +-- +-- Fake 2's complement for negative values (might be slow) +-- +-- @since 10.201.0 +integerSetBit :: Integer -> Word -> Integer +{-# INLINE integerSetBit #-} -- See Note [INLINE for constant folding of bit operations] +integerSetBit !i (W# n) = integerSetBit# i n + +-- | Clear the /n/-th bit. +-- +-- Fake 2's complement for negative values (might be slow) +-- +-- @since 10.201.0 +integerClearBit# :: Integer -> Word# -> Integer +{-# INLINE integerClearBit# #-} -- See Note [INLINE for constant folding of bit operations] +integerClearBit# n@(IS x) i + | isTrue# (i `ltWord#` (WORD_SIZE_IN_BITS## `minusWord#` 1##)) + = IS (x `andI#` notI# (uncheckedIShiftL# 1# (word2Int# i))) + | isTrue# (x >=# 0#) + = n + | True + = IN (bigNatAddWord# + (bigNatSetBit# + (bigNatFromWord# + (minusWord# (int2Word# (negateInt# x)) 1##)) + i) + 1##) +integerClearBit# (IP x) i = integerFromBigNat# (bigNatClearBit# x i) +integerClearBit# (IN x) i = IN (bigNatAddWord# + (bigNatSetBit# (bigNatSubWordUnsafe# x 1##) i) + 1##) + +-- | Clear the /n/-th bit. +-- +-- Fake 2's complement for negative values (might be slow) +-- +-- @since 10.201.0 +integerClearBit :: Integer -> Word -> Integer +{-# INLINE integerClearBit #-} -- See Note [INLINE for constant folding of bit operations] +integerClearBit !i (W# n) = integerClearBit# i n + +-- | Reverse the /n/-th bit. +-- +-- Fake 2's complement for negative values (might be slow) +-- +-- @since 10.201.0 +integerComplementBit# :: Integer -> Word# -> Integer +{-# INLINE integerComplementBit# #-} -- See Note [INLINE for constant folding of bit operations] +integerComplementBit# (IS x) i + | isTrue# (i `ltWord#` (WORD_SIZE_IN_BITS## `minusWord#` 1##)) + = IS (x `xorI#` uncheckedIShiftL# 1# (word2Int# i)) + | isTrue# (x >=# 0#) + = IP (bigNatSetBit# (bigNatFromWord# (int2Word# x)) i) + | True + = IN (bigNatAddWord# + (bigNatSetBit# + (bigNatFromWord# (minusWord# (int2Word# (negateInt# x)) 1##)) + i) + 1##) +integerComplementBit# (IP x) i = integerFromBigNat# (bigNatComplementBit# x i) +integerComplementBit# (IN x) i = integerFromBigNatNeg# + (bigNatAddWord# + (bigNatComplementBit# + (bigNatSubWordUnsafe# x 1##) + i) + 1##) + +-- | Reverse the /n/-th bit. +-- +-- Fake 2's complement for negative values (might be slow) +-- +-- @since 10.201.0 +integerComplementBit :: Integer -> Word -> Integer +{-# INLINE integerComplementBit #-} -- See Note [INLINE for constant folding of bit operations] +integerComplementBit !i (W# n) = integerComplementBit# i n + -- | Shift-right operation -- -- Fake 2's complement for negative values (might be slow) ===================================== libraries/ghc-internal/src/GHC/Internal/Bits.hs ===================================== @@ -564,6 +564,15 @@ instance Bits Integer where | otherwise = integerShiftR x (fromIntegral (negate i)) testBit x i = integerTestBit x (fromIntegral i) zeroBits = integerZero + -- INLINE on setBit/clearBit/complementBit preserves constant folding; + -- see Note [INLINE for constant folding of bit operations] in + -- GHC.Internal.Bignum.Integer. + setBit x i = integerSetBit x (fromIntegral i) + {-# INLINE setBit #-} + clearBit x i = integerClearBit x (fromIntegral i) + {-# INLINE clearBit #-} + complementBit x i = integerComplementBit x (fromIntegral i) + {-# INLINE complementBit #-} bit (I# i) = integerBit# (int2Word# i) popCount x = I# (integerPopCount# x) ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -8371,8 +8371,12 @@ module GHC.Num where integerBit# :: GHC.Internal.Prim.Word# -> Integer integerCheck :: Integer -> GHC.Internal.Types.Bool integerCheck# :: Integer -> GHC.Internal.Bignum.Primitives.Bool# + integerClearBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerClearBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerCompare :: Integer -> Integer -> GHC.Internal.Types.Ordering integerComplement :: Integer -> Integer + integerComplementBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerComplementBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerDecodeDouble# :: GHC.Internal.Prim.Double# -> (# Integer, GHC.Internal.Prim.Int# #) integerDiv :: Integer -> Integer -> Integer integerDivMod :: Integer -> Integer -> (Integer, Integer) @@ -8436,6 +8440,8 @@ module GHC.Num where integerQuotRem# :: Integer -> Integer -> (# Integer, Integer #) integerRecipMod# :: Integer -> Natural -> (# Natural | () #) integerRem :: Integer -> Integer -> Integer + integerSetBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerSetBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftL :: Integer -> GHC.Internal.Types.Word -> Integer integerShiftL# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftR :: Integer -> GHC.Internal.Types.Word -> Integer ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -8409,8 +8409,12 @@ module GHC.Num where integerBit# :: GHC.Internal.Prim.Word# -> Integer integerCheck :: Integer -> GHC.Internal.Types.Bool integerCheck# :: Integer -> GHC.Internal.Bignum.Primitives.Bool# + integerClearBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerClearBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerCompare :: Integer -> Integer -> GHC.Internal.Types.Ordering integerComplement :: Integer -> Integer + integerComplementBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerComplementBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerDecodeDouble# :: GHC.Internal.Prim.Double# -> (# Integer, GHC.Internal.Prim.Int# #) integerDiv :: Integer -> Integer -> Integer integerDivMod :: Integer -> Integer -> (Integer, Integer) @@ -8474,6 +8478,8 @@ module GHC.Num where integerQuotRem# :: Integer -> Integer -> (# Integer, Integer #) integerRecipMod# :: Integer -> Natural -> (# Natural | () #) integerRem :: Integer -> Integer -> Integer + integerSetBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerSetBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftL :: Integer -> GHC.Internal.Types.Word -> Integer integerShiftL# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftR :: Integer -> GHC.Internal.Types.Word -> Integer ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -8589,8 +8589,12 @@ module GHC.Num where integerBit# :: GHC.Internal.Prim.Word# -> Integer integerCheck :: Integer -> GHC.Internal.Types.Bool integerCheck# :: Integer -> GHC.Internal.Bignum.Primitives.Bool# + integerClearBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerClearBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerCompare :: Integer -> Integer -> GHC.Internal.Types.Ordering integerComplement :: Integer -> Integer + integerComplementBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerComplementBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerDecodeDouble# :: GHC.Internal.Prim.Double# -> (# Integer, GHC.Internal.Prim.Int# #) integerDiv :: Integer -> Integer -> Integer integerDivMod :: Integer -> Integer -> (Integer, Integer) @@ -8654,6 +8658,8 @@ module GHC.Num where integerQuotRem# :: Integer -> Integer -> (# Integer, Integer #) integerRecipMod# :: Integer -> Natural -> (# Natural | () #) integerRem :: Integer -> Integer -> Integer + integerSetBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerSetBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftL :: Integer -> GHC.Internal.Types.Word -> Integer integerShiftL# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftR :: Integer -> GHC.Internal.Types.Word -> Integer ===================================== testsuite/tests/interface-stability/ghc-bignum-exports.stdout ===================================== @@ -201,8 +201,12 @@ module GHC.Num.Integer where integerBit# :: GHC.Internal.Prim.Word# -> Integer integerCheck :: Integer -> GHC.Internal.Types.Bool integerCheck# :: Integer -> GHC.Internal.Bignum.Primitives.Bool# + integerClearBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerClearBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerCompare :: Integer -> Integer -> GHC.Internal.Types.Ordering integerComplement :: Integer -> Integer + integerComplementBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerComplementBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerDecodeDouble# :: GHC.Internal.Prim.Double# -> (# Integer, GHC.Internal.Prim.Int# #) integerDiv :: Integer -> Integer -> Integer integerDivMod :: Integer -> Integer -> (Integer, Integer) @@ -266,6 +270,8 @@ module GHC.Num.Integer where integerQuotRem# :: Integer -> Integer -> (# Integer, Integer #) integerRecipMod# :: Integer -> GHC.Internal.Bignum.Natural.Natural -> (# GHC.Internal.Bignum.Natural.Natural | () #) integerRem :: Integer -> Integer -> Integer + integerSetBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerSetBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftL :: Integer -> GHC.Internal.Types.Word -> Integer integerShiftL# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftR :: Integer -> GHC.Internal.Types.Word -> Integer ===================================== testsuite/tests/numeric/should_run/T21176.hs ===================================== @@ -0,0 +1,37 @@ +module Main where + +import Data.Bits +import Data.Int (Int32, Int64) +import Data.Foldable (for_) +import GHC.Num.Integer (integerCheck) + +integers :: [Integer] +integers = concatMap neighbours [minInt64, minInt32, 0, maxInt32, maxInt64] + where + neighbours i = [i - 2, i - 1, i, i + 1, i + 2] + minInt64 = toInteger (minBound :: Int64) + minInt32 = toInteger (minBound :: Int32) + maxInt32 = toInteger (maxBound :: Int32) + maxInt64 = toInteger (maxBound :: Int64) + +bits :: [Int] +bits = [0, 1, 62, 63, 64] + +testXBit :: String -> (Integer -> Int -> Integer) -> (Integer -> Int -> Integer) -> IO () +testXBit name f model = do + putStrLn name + for_ integers $ \i -> + for_ bits $ \b -> do + let actual = f i b + expected = model i b + valid = if integerCheck actual then "valid" else "invalid" + matches = if actual == expected then "matches" else "differs" + putStrLn $ " " ++ show i ++ " " ++ show b ++ " -> " ++ show actual + ++ " [" ++ valid ++ ", " ++ matches ++ "]" + putStrLn "" + +main :: IO () +main = do + testXBit "setBit" setBit (\i b -> i .|. bit b) + testXBit "clearBit" clearBit (\i b -> i .&. complement (bit b)) + testXBit "complementBit" complementBit (\i b -> i `xor` bit b) ===================================== testsuite/tests/numeric/should_run/T21176.stdout ===================================== @@ -0,0 +1,381 @@ +setBit + -9223372036854775810 0 -> -9223372036854775809 [valid, matches] + -9223372036854775810 1 -> -9223372036854775810 [valid, matches] + -9223372036854775810 62 -> -9223372036854775810 [valid, matches] + -9223372036854775810 63 -> -2 [valid, matches] + -9223372036854775810 64 -> -9223372036854775810 [valid, matches] + -9223372036854775809 0 -> -9223372036854775809 [valid, matches] + -9223372036854775809 1 -> -9223372036854775809 [valid, matches] + -9223372036854775809 62 -> -9223372036854775809 [valid, matches] + -9223372036854775809 63 -> -1 [valid, matches] + -9223372036854775809 64 -> -9223372036854775809 [valid, matches] + -9223372036854775808 0 -> -9223372036854775807 [valid, matches] + -9223372036854775808 1 -> -9223372036854775806 [valid, matches] + -9223372036854775808 62 -> -4611686018427387904 [valid, matches] + -9223372036854775808 63 -> -9223372036854775808 [valid, matches] + -9223372036854775808 64 -> -9223372036854775808 [valid, matches] + -9223372036854775807 0 -> -9223372036854775807 [valid, matches] + -9223372036854775807 1 -> -9223372036854775805 [valid, matches] + -9223372036854775807 62 -> -4611686018427387903 [valid, matches] + -9223372036854775807 63 -> -9223372036854775807 [valid, matches] + -9223372036854775807 64 -> -9223372036854775807 [valid, matches] + -9223372036854775806 0 -> -9223372036854775805 [valid, matches] + -9223372036854775806 1 -> -9223372036854775806 [valid, matches] + -9223372036854775806 62 -> -4611686018427387902 [valid, matches] + -9223372036854775806 63 -> -9223372036854775806 [valid, matches] + -9223372036854775806 64 -> -9223372036854775806 [valid, matches] + -2147483650 0 -> -2147483649 [valid, matches] + -2147483650 1 -> -2147483650 [valid, matches] + -2147483650 62 -> -2147483650 [valid, matches] + -2147483650 63 -> -2147483650 [valid, matches] + -2147483650 64 -> -2147483650 [valid, matches] + -2147483649 0 -> -2147483649 [valid, matches] + -2147483649 1 -> -2147483649 [valid, matches] + -2147483649 62 -> -2147483649 [valid, matches] + -2147483649 63 -> -2147483649 [valid, matches] + -2147483649 64 -> -2147483649 [valid, matches] + -2147483648 0 -> -2147483647 [valid, matches] + -2147483648 1 -> -2147483646 [valid, matches] + -2147483648 62 -> -2147483648 [valid, matches] + -2147483648 63 -> -2147483648 [valid, matches] + -2147483648 64 -> -2147483648 [valid, matches] + -2147483647 0 -> -2147483647 [valid, matches] + -2147483647 1 -> -2147483645 [valid, matches] + -2147483647 62 -> -2147483647 [valid, matches] + -2147483647 63 -> -2147483647 [valid, matches] + -2147483647 64 -> -2147483647 [valid, matches] + -2147483646 0 -> -2147483645 [valid, matches] + -2147483646 1 -> -2147483646 [valid, matches] + -2147483646 62 -> -2147483646 [valid, matches] + -2147483646 63 -> -2147483646 [valid, matches] + -2147483646 64 -> -2147483646 [valid, matches] + -2 0 -> -1 [valid, matches] + -2 1 -> -2 [valid, matches] + -2 62 -> -2 [valid, matches] + -2 63 -> -2 [valid, matches] + -2 64 -> -2 [valid, matches] + -1 0 -> -1 [valid, matches] + -1 1 -> -1 [valid, matches] + -1 62 -> -1 [valid, matches] + -1 63 -> -1 [valid, matches] + -1 64 -> -1 [valid, matches] + 0 0 -> 1 [valid, matches] + 0 1 -> 2 [valid, matches] + 0 62 -> 4611686018427387904 [valid, matches] + 0 63 -> 9223372036854775808 [valid, matches] + 0 64 -> 18446744073709551616 [valid, matches] + 1 0 -> 1 [valid, matches] + 1 1 -> 3 [valid, matches] + 1 62 -> 4611686018427387905 [valid, matches] + 1 63 -> 9223372036854775809 [valid, matches] + 1 64 -> 18446744073709551617 [valid, matches] + 2 0 -> 3 [valid, matches] + 2 1 -> 2 [valid, matches] + 2 62 -> 4611686018427387906 [valid, matches] + 2 63 -> 9223372036854775810 [valid, matches] + 2 64 -> 18446744073709551618 [valid, matches] + 2147483645 0 -> 2147483645 [valid, matches] + 2147483645 1 -> 2147483647 [valid, matches] + 2147483645 62 -> 4611686020574871549 [valid, matches] + 2147483645 63 -> 9223372039002259453 [valid, matches] + 2147483645 64 -> 18446744075857035261 [valid, matches] + 2147483646 0 -> 2147483647 [valid, matches] + 2147483646 1 -> 2147483646 [valid, matches] + 2147483646 62 -> 4611686020574871550 [valid, matches] + 2147483646 63 -> 9223372039002259454 [valid, matches] + 2147483646 64 -> 18446744075857035262 [valid, matches] + 2147483647 0 -> 2147483647 [valid, matches] + 2147483647 1 -> 2147483647 [valid, matches] + 2147483647 62 -> 4611686020574871551 [valid, matches] + 2147483647 63 -> 9223372039002259455 [valid, matches] + 2147483647 64 -> 18446744075857035263 [valid, matches] + 2147483648 0 -> 2147483649 [valid, matches] + 2147483648 1 -> 2147483650 [valid, matches] + 2147483648 62 -> 4611686020574871552 [valid, matches] + 2147483648 63 -> 9223372039002259456 [valid, matches] + 2147483648 64 -> 18446744075857035264 [valid, matches] + 2147483649 0 -> 2147483649 [valid, matches] + 2147483649 1 -> 2147483651 [valid, matches] + 2147483649 62 -> 4611686020574871553 [valid, matches] + 2147483649 63 -> 9223372039002259457 [valid, matches] + 2147483649 64 -> 18446744075857035265 [valid, matches] + 9223372036854775805 0 -> 9223372036854775805 [valid, matches] + 9223372036854775805 1 -> 9223372036854775807 [valid, matches] + 9223372036854775805 62 -> 9223372036854775805 [valid, matches] + 9223372036854775805 63 -> 18446744073709551613 [valid, matches] + 9223372036854775805 64 -> 27670116110564327421 [valid, matches] + 9223372036854775806 0 -> 9223372036854775807 [valid, matches] + 9223372036854775806 1 -> 9223372036854775806 [valid, matches] + 9223372036854775806 62 -> 9223372036854775806 [valid, matches] + 9223372036854775806 63 -> 18446744073709551614 [valid, matches] + 9223372036854775806 64 -> 27670116110564327422 [valid, matches] + 9223372036854775807 0 -> 9223372036854775807 [valid, matches] + 9223372036854775807 1 -> 9223372036854775807 [valid, matches] + 9223372036854775807 62 -> 9223372036854775807 [valid, matches] + 9223372036854775807 63 -> 18446744073709551615 [valid, matches] + 9223372036854775807 64 -> 27670116110564327423 [valid, matches] + 9223372036854775808 0 -> 9223372036854775809 [valid, matches] + 9223372036854775808 1 -> 9223372036854775810 [valid, matches] + 9223372036854775808 62 -> 13835058055282163712 [valid, matches] + 9223372036854775808 63 -> 9223372036854775808 [valid, matches] + 9223372036854775808 64 -> 27670116110564327424 [valid, matches] + 9223372036854775809 0 -> 9223372036854775809 [valid, matches] + 9223372036854775809 1 -> 9223372036854775811 [valid, matches] + 9223372036854775809 62 -> 13835058055282163713 [valid, matches] + 9223372036854775809 63 -> 9223372036854775809 [valid, matches] + 9223372036854775809 64 -> 27670116110564327425 [valid, matches] + +clearBit + -9223372036854775810 0 -> -9223372036854775810 [valid, matches] + -9223372036854775810 1 -> -9223372036854775812 [valid, matches] + -9223372036854775810 62 -> -13835058055282163714 [valid, matches] + -9223372036854775810 63 -> -9223372036854775810 [valid, matches] + -9223372036854775810 64 -> -27670116110564327426 [valid, matches] + -9223372036854775809 0 -> -9223372036854775810 [valid, matches] + -9223372036854775809 1 -> -9223372036854775811 [valid, matches] + -9223372036854775809 62 -> -13835058055282163713 [valid, matches] + -9223372036854775809 63 -> -9223372036854775809 [valid, matches] + -9223372036854775809 64 -> -27670116110564327425 [valid, matches] + -9223372036854775808 0 -> -9223372036854775808 [valid, matches] + -9223372036854775808 1 -> -9223372036854775808 [valid, matches] + -9223372036854775808 62 -> -9223372036854775808 [valid, matches] + -9223372036854775808 63 -> -18446744073709551616 [valid, matches] + -9223372036854775808 64 -> -27670116110564327424 [valid, matches] + -9223372036854775807 0 -> -9223372036854775808 [valid, matches] + -9223372036854775807 1 -> -9223372036854775807 [valid, matches] + -9223372036854775807 62 -> -9223372036854775807 [valid, matches] + -9223372036854775807 63 -> -18446744073709551615 [valid, matches] + -9223372036854775807 64 -> -27670116110564327423 [valid, matches] + -9223372036854775806 0 -> -9223372036854775806 [valid, matches] + -9223372036854775806 1 -> -9223372036854775808 [valid, matches] + -9223372036854775806 62 -> -9223372036854775806 [valid, matches] + -9223372036854775806 63 -> -18446744073709551614 [valid, matches] + -9223372036854775806 64 -> -27670116110564327422 [valid, matches] + -2147483650 0 -> -2147483650 [valid, matches] + -2147483650 1 -> -2147483652 [valid, matches] + -2147483650 62 -> -4611686020574871554 [valid, matches] + -2147483650 63 -> -9223372039002259458 [valid, matches] + -2147483650 64 -> -18446744075857035266 [valid, matches] + -2147483649 0 -> -2147483650 [valid, matches] + -2147483649 1 -> -2147483651 [valid, matches] + -2147483649 62 -> -4611686020574871553 [valid, matches] + -2147483649 63 -> -9223372039002259457 [valid, matches] + -2147483649 64 -> -18446744075857035265 [valid, matches] + -2147483648 0 -> -2147483648 [valid, matches] + -2147483648 1 -> -2147483648 [valid, matches] + -2147483648 62 -> -4611686020574871552 [valid, matches] + -2147483648 63 -> -9223372039002259456 [valid, matches] + -2147483648 64 -> -18446744075857035264 [valid, matches] + -2147483647 0 -> -2147483648 [valid, matches] + -2147483647 1 -> -2147483647 [valid, matches] + -2147483647 62 -> -4611686020574871551 [valid, matches] + -2147483647 63 -> -9223372039002259455 [valid, matches] + -2147483647 64 -> -18446744075857035263 [valid, matches] + -2147483646 0 -> -2147483646 [valid, matches] + -2147483646 1 -> -2147483648 [valid, matches] + -2147483646 62 -> -4611686020574871550 [valid, matches] + -2147483646 63 -> -9223372039002259454 [valid, matches] + -2147483646 64 -> -18446744075857035262 [valid, matches] + -2 0 -> -2 [valid, matches] + -2 1 -> -4 [valid, matches] + -2 62 -> -4611686018427387906 [valid, matches] + -2 63 -> -9223372036854775810 [valid, matches] + -2 64 -> -18446744073709551618 [valid, matches] + -1 0 -> -2 [valid, matches] + -1 1 -> -3 [valid, matches] + -1 62 -> -4611686018427387905 [valid, matches] + -1 63 -> -9223372036854775809 [valid, matches] + -1 64 -> -18446744073709551617 [valid, matches] + 0 0 -> 0 [valid, matches] + 0 1 -> 0 [valid, matches] + 0 62 -> 0 [valid, matches] + 0 63 -> 0 [valid, matches] + 0 64 -> 0 [valid, matches] + 1 0 -> 0 [valid, matches] + 1 1 -> 1 [valid, matches] + 1 62 -> 1 [valid, matches] + 1 63 -> 1 [valid, matches] + 1 64 -> 1 [valid, matches] + 2 0 -> 2 [valid, matches] + 2 1 -> 0 [valid, matches] + 2 62 -> 2 [valid, matches] + 2 63 -> 2 [valid, matches] + 2 64 -> 2 [valid, matches] + 2147483645 0 -> 2147483644 [valid, matches] + 2147483645 1 -> 2147483645 [valid, matches] + 2147483645 62 -> 2147483645 [valid, matches] + 2147483645 63 -> 2147483645 [valid, matches] + 2147483645 64 -> 2147483645 [valid, matches] + 2147483646 0 -> 2147483646 [valid, matches] + 2147483646 1 -> 2147483644 [valid, matches] + 2147483646 62 -> 2147483646 [valid, matches] + 2147483646 63 -> 2147483646 [valid, matches] + 2147483646 64 -> 2147483646 [valid, matches] + 2147483647 0 -> 2147483646 [valid, matches] + 2147483647 1 -> 2147483645 [valid, matches] + 2147483647 62 -> 2147483647 [valid, matches] + 2147483647 63 -> 2147483647 [valid, matches] + 2147483647 64 -> 2147483647 [valid, matches] + 2147483648 0 -> 2147483648 [valid, matches] + 2147483648 1 -> 2147483648 [valid, matches] + 2147483648 62 -> 2147483648 [valid, matches] + 2147483648 63 -> 2147483648 [valid, matches] + 2147483648 64 -> 2147483648 [valid, matches] + 2147483649 0 -> 2147483648 [valid, matches] + 2147483649 1 -> 2147483649 [valid, matches] + 2147483649 62 -> 2147483649 [valid, matches] + 2147483649 63 -> 2147483649 [valid, matches] + 2147483649 64 -> 2147483649 [valid, matches] + 9223372036854775805 0 -> 9223372036854775804 [valid, matches] + 9223372036854775805 1 -> 9223372036854775805 [valid, matches] + 9223372036854775805 62 -> 4611686018427387901 [valid, matches] + 9223372036854775805 63 -> 9223372036854775805 [valid, matches] + 9223372036854775805 64 -> 9223372036854775805 [valid, matches] + 9223372036854775806 0 -> 9223372036854775806 [valid, matches] + 9223372036854775806 1 -> 9223372036854775804 [valid, matches] + 9223372036854775806 62 -> 4611686018427387902 [valid, matches] + 9223372036854775806 63 -> 9223372036854775806 [valid, matches] + 9223372036854775806 64 -> 9223372036854775806 [valid, matches] + 9223372036854775807 0 -> 9223372036854775806 [valid, matches] + 9223372036854775807 1 -> 9223372036854775805 [valid, matches] + 9223372036854775807 62 -> 4611686018427387903 [valid, matches] + 9223372036854775807 63 -> 9223372036854775807 [valid, matches] + 9223372036854775807 64 -> 9223372036854775807 [valid, matches] + 9223372036854775808 0 -> 9223372036854775808 [valid, matches] + 9223372036854775808 1 -> 9223372036854775808 [valid, matches] + 9223372036854775808 62 -> 9223372036854775808 [valid, matches] + 9223372036854775808 63 -> 0 [valid, matches] + 9223372036854775808 64 -> 9223372036854775808 [valid, matches] + 9223372036854775809 0 -> 9223372036854775808 [valid, matches] + 9223372036854775809 1 -> 9223372036854775809 [valid, matches] + 9223372036854775809 62 -> 9223372036854775809 [valid, matches] + 9223372036854775809 63 -> 1 [valid, matches] + 9223372036854775809 64 -> 9223372036854775809 [valid, matches] + +complementBit + -9223372036854775810 0 -> -9223372036854775809 [valid, matches] + -9223372036854775810 1 -> -9223372036854775812 [valid, matches] + -9223372036854775810 62 -> -13835058055282163714 [valid, matches] + -9223372036854775810 63 -> -2 [valid, matches] + -9223372036854775810 64 -> -27670116110564327426 [valid, matches] + -9223372036854775809 0 -> -9223372036854775810 [valid, matches] + -9223372036854775809 1 -> -9223372036854775811 [valid, matches] + -9223372036854775809 62 -> -13835058055282163713 [valid, matches] + -9223372036854775809 63 -> -1 [valid, matches] + -9223372036854775809 64 -> -27670116110564327425 [valid, matches] + -9223372036854775808 0 -> -9223372036854775807 [valid, matches] + -9223372036854775808 1 -> -9223372036854775806 [valid, matches] + -9223372036854775808 62 -> -4611686018427387904 [valid, matches] + -9223372036854775808 63 -> -18446744073709551616 [valid, matches] + -9223372036854775808 64 -> -27670116110564327424 [valid, matches] + -9223372036854775807 0 -> -9223372036854775808 [valid, matches] + -9223372036854775807 1 -> -9223372036854775805 [valid, matches] + -9223372036854775807 62 -> -4611686018427387903 [valid, matches] + -9223372036854775807 63 -> -18446744073709551615 [valid, matches] + -9223372036854775807 64 -> -27670116110564327423 [valid, matches] + -9223372036854775806 0 -> -9223372036854775805 [valid, matches] + -9223372036854775806 1 -> -9223372036854775808 [valid, matches] + -9223372036854775806 62 -> -4611686018427387902 [valid, matches] + -9223372036854775806 63 -> -18446744073709551614 [valid, matches] + -9223372036854775806 64 -> -27670116110564327422 [valid, matches] + -2147483650 0 -> -2147483649 [valid, matches] + -2147483650 1 -> -2147483652 [valid, matches] + -2147483650 62 -> -4611686020574871554 [valid, matches] + -2147483650 63 -> -9223372039002259458 [valid, matches] + -2147483650 64 -> -18446744075857035266 [valid, matches] + -2147483649 0 -> -2147483650 [valid, matches] + -2147483649 1 -> -2147483651 [valid, matches] + -2147483649 62 -> -4611686020574871553 [valid, matches] + -2147483649 63 -> -9223372039002259457 [valid, matches] + -2147483649 64 -> -18446744075857035265 [valid, matches] + -2147483648 0 -> -2147483647 [valid, matches] + -2147483648 1 -> -2147483646 [valid, matches] + -2147483648 62 -> -4611686020574871552 [valid, matches] + -2147483648 63 -> -9223372039002259456 [valid, matches] + -2147483648 64 -> -18446744075857035264 [valid, matches] + -2147483647 0 -> -2147483648 [valid, matches] + -2147483647 1 -> -2147483645 [valid, matches] + -2147483647 62 -> -4611686020574871551 [valid, matches] + -2147483647 63 -> -9223372039002259455 [valid, matches] + -2147483647 64 -> -18446744075857035263 [valid, matches] + -2147483646 0 -> -2147483645 [valid, matches] + -2147483646 1 -> -2147483648 [valid, matches] + -2147483646 62 -> -4611686020574871550 [valid, matches] + -2147483646 63 -> -9223372039002259454 [valid, matches] + -2147483646 64 -> -18446744075857035262 [valid, matches] + -2 0 -> -1 [valid, matches] + -2 1 -> -4 [valid, matches] + -2 62 -> -4611686018427387906 [valid, matches] + -2 63 -> -9223372036854775810 [valid, matches] + -2 64 -> -18446744073709551618 [valid, matches] + -1 0 -> -2 [valid, matches] + -1 1 -> -3 [valid, matches] + -1 62 -> -4611686018427387905 [valid, matches] + -1 63 -> -9223372036854775809 [valid, matches] + -1 64 -> -18446744073709551617 [valid, matches] + 0 0 -> 1 [valid, matches] + 0 1 -> 2 [valid, matches] + 0 62 -> 4611686018427387904 [valid, matches] + 0 63 -> 9223372036854775808 [valid, matches] + 0 64 -> 18446744073709551616 [valid, matches] + 1 0 -> 0 [valid, matches] + 1 1 -> 3 [valid, matches] + 1 62 -> 4611686018427387905 [valid, matches] + 1 63 -> 9223372036854775809 [valid, matches] + 1 64 -> 18446744073709551617 [valid, matches] + 2 0 -> 3 [valid, matches] + 2 1 -> 0 [valid, matches] + 2 62 -> 4611686018427387906 [valid, matches] + 2 63 -> 9223372036854775810 [valid, matches] + 2 64 -> 18446744073709551618 [valid, matches] + 2147483645 0 -> 2147483644 [valid, matches] + 2147483645 1 -> 2147483647 [valid, matches] + 2147483645 62 -> 4611686020574871549 [valid, matches] + 2147483645 63 -> 9223372039002259453 [valid, matches] + 2147483645 64 -> 18446744075857035261 [valid, matches] + 2147483646 0 -> 2147483647 [valid, matches] + 2147483646 1 -> 2147483644 [valid, matches] + 2147483646 62 -> 4611686020574871550 [valid, matches] + 2147483646 63 -> 9223372039002259454 [valid, matches] + 2147483646 64 -> 18446744075857035262 [valid, matches] + 2147483647 0 -> 2147483646 [valid, matches] + 2147483647 1 -> 2147483645 [valid, matches] + 2147483647 62 -> 4611686020574871551 [valid, matches] + 2147483647 63 -> 9223372039002259455 [valid, matches] + 2147483647 64 -> 18446744075857035263 [valid, matches] + 2147483648 0 -> 2147483649 [valid, matches] + 2147483648 1 -> 2147483650 [valid, matches] + 2147483648 62 -> 4611686020574871552 [valid, matches] + 2147483648 63 -> 9223372039002259456 [valid, matches] + 2147483648 64 -> 18446744075857035264 [valid, matches] + 2147483649 0 -> 2147483648 [valid, matches] + 2147483649 1 -> 2147483651 [valid, matches] + 2147483649 62 -> 4611686020574871553 [valid, matches] + 2147483649 63 -> 9223372039002259457 [valid, matches] + 2147483649 64 -> 18446744075857035265 [valid, matches] + 9223372036854775805 0 -> 9223372036854775804 [valid, matches] + 9223372036854775805 1 -> 9223372036854775807 [valid, matches] + 9223372036854775805 62 -> 4611686018427387901 [valid, matches] + 9223372036854775805 63 -> 18446744073709551613 [valid, matches] + 9223372036854775805 64 -> 27670116110564327421 [valid, matches] + 9223372036854775806 0 -> 9223372036854775807 [valid, matches] + 9223372036854775806 1 -> 9223372036854775804 [valid, matches] + 9223372036854775806 62 -> 4611686018427387902 [valid, matches] + 9223372036854775806 63 -> 18446744073709551614 [valid, matches] + 9223372036854775806 64 -> 27670116110564327422 [valid, matches] + 9223372036854775807 0 -> 9223372036854775806 [valid, matches] + 9223372036854775807 1 -> 9223372036854775805 [valid, matches] + 9223372036854775807 62 -> 4611686018427387903 [valid, matches] + 9223372036854775807 63 -> 18446744073709551615 [valid, matches] + 9223372036854775807 64 -> 27670116110564327423 [valid, matches] + 9223372036854775808 0 -> 9223372036854775809 [valid, matches] + 9223372036854775808 1 -> 9223372036854775810 [valid, matches] + 9223372036854775808 62 -> 13835058055282163712 [valid, matches] + 9223372036854775808 63 -> 0 [valid, matches] + 9223372036854775808 64 -> 27670116110564327424 [valid, matches] + 9223372036854775809 0 -> 9223372036854775808 [valid, matches] + 9223372036854775809 1 -> 9223372036854775811 [valid, matches] + 9223372036854775809 62 -> 13835058055282163713 [valid, matches] + 9223372036854775809 63 -> 1 [valid, matches] + 9223372036854775809 64 -> 27670116110564327425 [valid, matches] + ===================================== testsuite/tests/numeric/should_run/all.T ===================================== @@ -101,3 +101,4 @@ test('T24245', normal, compile_and_run, ['']) test('T25653', normal, compile_and_run, ['']) test('T18619', exit_code(1), compile_and_run, ['']) test('T26230', normal, compile_and_run, ['']) +test('T21176', normal, compile_and_run, ['']) ===================================== testsuite/tests/simplCore/should_compile/T8832.hs ===================================== @@ -23,3 +23,9 @@ T(w32,Word32) T(w64,Word64) T(z,Integer) + +zset :: Integer +zset = setBit (bit 0) 0 + +zcompl :: Integer +zcompl = complementBit (bit 0) 0 ===================================== testsuite/tests/simplCore/should_compile/T8832.stdout ===================================== @@ -8,4 +8,6 @@ w8 = GHC.Internal.Word.W8# 0#Word8 w16 = GHC.Internal.Word.W16# 0#Word16 w32 = GHC.Internal.Word.W32# 0#Word32 w64 = GHC.Internal.Word.W64# 0#Word64 -z = GHC.Internal.Bignum.Integer.IS 0# +zcompl = GHC.Internal.Bignum.Integer.IS 0# +zset = GHC.Internal.Bignum.Integer.IS 1# +z = zcompl View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/46e878800f117c21bfb317030401e45… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/46e878800f117c21bfb317030401e45… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/T21176-integer-bits] 5 commits: Hadrian: convert env variable ACLOCAL_PATH to unix paths.
by Simon Jakobi (＠sjakobi2) 09 Jun '26

09 Jun '26

Simon Jakobi pushed to branch wip/sjakobi/T21176-integer-bits at Glasgow Haskell Compiler / GHC Commits: a3b431f3 by David Eichmann at 2026-06-04T10:10:19+00:00 Hadrian: convert env variable ACLOCAL_PATH to unix paths. Convert ACLOCAL_PATH to a unix style path when invoking autoreconf. Autoreconf doesn't handle windows paths. See Note [Autoreconf unix paths from ACLOCAL_PATH]. Fixes #27311 - - - - - 18f6138a by Simon Jakobi at 2026-06-04T20:20:31-04:00 testsuite: Deduplicate --only test names config.only is assumed to be a set, but supplying --only overwrote it with the (list) argparse result, which can contain duplicates. When a test ran, config.only.remove(name) dropped only the first occurrence, so a duplicated name lingered and was later misreported as a "test not found" framework failure. Store it as a set instead. Fixes #27322 Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - 2f3cc9ff by Simon Jakobi at 2026-06-08T07:55:49-04:00 testsuite: detect fast bignum via ghc-internal, not removed ghc-bignum The ghc-bignum package was merged into ghc-internal, so the BIGNUM_GMP probe in test.mk ran `ghc-pkg field ghc-bignum exposed-modules`, which fails with "cannot find package ghc-bignum". That error went to stderr and leaked into the captured stderr of every makefile_test, causing spurious [bad stderr] failures across the suite. The probe also silently returned empty, so config.have_fast_bignum was wrongly False even on GMP builds. Probe ghc-internal's extra-libraries for the gmp library instead: the GMP backend module is an other-module (not exposed), but GMP_LIBS adds gmp to extra-libraries only on a GMP build, so this distinguishes the backends. Redirect stderr to keep any future missing-package error off the harness's stderr. This also removes a stale comment as per suggestion from hsyl20. Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - eb3bf6e7 by Alan Zimmerman at 2026-06-08T07:56:32-04:00 EPA: Rename Transform.anchorEof to addModuleCommentOrigDeltas This now matches what it actually does. - - - - - 97e7fd17 by Simon Jakobi at 2026-06-09T14:41:18+02:00 Add explicit setBit/clearBit/complementBit for instance Bits Integer (#21176) The default setBit, clearBit, and complementBit methods allocate intermediate Integers per call. Define them explicitly via the new integerSetBit[#], integerClearBit[#] and integerComplementBit[#], built on the BigNat# primitives, which avoid those allocations. Allocation is not eliminated entirely -- the negative (IN) cases would need in-place mutation, which is left as future work. The default methods constant-folded on literal arguments via the integerOr/integerAnd/integerXor rules, which fold literal Integers of any size. The explicit functions have no such rule, so they (their Word-argument wrappers, and the Bits Integer methods) are marked INLINE to expose the underlying primops to the simplifier; see Note [INLINE for constant folding of bit operations]. This restores folding only on the small-int (IS) path -- large literal Integers (IP/IN) are no longer constant-folded, a minor regression for that case. T8832 covers the IS-path folding. The new golden-output test T21176 checks all three operations against the default implementations across the sign/size boundaries, recording each result plus its integerCheck validity. The base and ghc-bignum interface- stability export goldens gain the new functions. The changelog entry lives in changelog.d under a new ghc-internal section (renamed from ghc-prim). Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - 21 changed files: - boot - + changelog.d/T21176 - changelog.d/config - hadrian/src/Hadrian/Oracles/Path.hs - hadrian/src/Rules/BinaryDist.hs - libraries/base/changelog.md - libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs - libraries/ghc-internal/src/GHC/Internal/Bits.hs - testsuite/driver/runtests.py - testsuite/mk/test.mk - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-bignum-exports.stdout - + testsuite/tests/numeric/should_run/T21176.hs - + testsuite/tests/numeric/should_run/T21176.stdout - testsuite/tests/numeric/should_run/all.T - testsuite/tests/simplCore/should_compile/T8832.hs - testsuite/tests/simplCore/should_compile/T8832.stdout - utils/check-exact/Main.hs - utils/check-exact/Transform.hs Changes: ===================================== boot ===================================== @@ -52,9 +52,8 @@ def autoreconf(): # Run autoreconf on everything that needs it. processes = {} if os.name == 'nt': - # Get the normalized ACLOCAL_PATH for Windows - # This is necessary since on Windows this will be a Windows - # path, which autoreconf doesn't know doesn't know how to handle. + # Convert ACLOCAL_PATH env variable to unix style paths on Windows + # See Note [Autoreconf unix paths from ACLOCAL_PATH] ac_local = os.getenv('ACLOCAL_PATH', '') ac_local_arg = re.sub(r';', r':', ac_local) ac_local_arg = re.sub(r'\\', r'/', ac_local_arg) ===================================== changelog.d/T21176 ===================================== @@ -0,0 +1,4 @@ +section: ghc-internal +synopsis: Give ``setBit``, ``clearBit`` and ``complementBit`` explicit definitions in ``instance Bits Integer``, backed by new ``integerSetBit[#]``, ``integerClearBit[#]`` and ``integerComplementBit[#]`` functions. These avoid the intermediate ``Integer`` allocations of the previous default methods, although allocation is not eliminated entirely — notably the negative (``IN``) cases would require in-place mutation, which is left as future work. As a trade-off, constant folding of these operations now applies only to small (machine-word-sized) literal arguments; the previous default methods folded literal ``Integer`` arguments of any size via the ``integerOr``/``integerAnd``/``integerXor`` rules. +issues: #21176 +mrs: !7772 ===================================== changelog.d/config ===================================== @@ -27,7 +27,7 @@ sections: { cmm Cmm build-tools Build tools base ``base`` library - ghc-prim ``ghc-prim`` library + ghc-internal ``ghc-internal`` library ghc-lib ``ghc`` library ghc-heap ``ghc-heap`` library ghc-experimental ``ghc-experimental`` library ===================================== hadrian/src/Hadrian/Oracles/Path.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} module Hadrian.Oracles.Path ( - lookupInPath, fixAbsolutePathOnWindows, pathOracle + lookupInPath, fixAbsolutePathOnWindows, fixUnixPathsOnWindows, + pathOracle ) where import Control.Monad @@ -33,6 +34,14 @@ fixAbsolutePathOnWindows path = else return path +-- | Fix a unix path list on Windows: +-- * "C:\\foo\\bar;C:\\msys2\\bin" => "/c/foo/bar:/c/msys2/bin" +fixUnixPathsOnWindows :: FilePath -> Action FilePath +fixUnixPathsOnWindows paths = + if isWindows + then askOracle $ UnixPathList paths + else return paths + newtype LookupInPath = LookupInPath String deriving (Binary, Eq, Hashable, NFData, Show) type instance RuleResult LookupInPath = String @@ -41,6 +50,10 @@ newtype WindowsPath = WindowsPath FilePath deriving (Binary, Eq, Hashable, NFData, Show) type instance RuleResult WindowsPath = String +newtype UnixPathList = UnixPathList FilePath + deriving (Binary, Eq, Hashable, NFData, Show) +type instance RuleResult UnixPathList = String + -- | Oracles for looking up paths. These are slow and require caching. pathOracle :: Rules () pathOracle = do @@ -50,6 +63,12 @@ pathOracle = do putVerbose $ "| Windows path mapping: " ++ path ++ " => " ++ windowsPath return windowsPath + void $ addOracleCache $ \(UnixPathList paths) -> do + Stdout out <- quietly $ cmd ["cygpath", "-p", "-u", paths] + let unixPaths = unifyPath $ dropWhileEnd isSpace out + putVerbose $ "| Unix path mapping: " ++ paths ++ " => " ++ unixPaths + return unixPaths + void $ addOracleCache $ \(LookupInPath name) -> do path <- liftIO getSearchPath exes <- liftIO (findExecutablesInDirectories path name) ===================================== hadrian/src/Rules/BinaryDist.hs ===================================== @@ -3,18 +3,19 @@ module Rules.BinaryDist where import CommandLine import Context +import Data.Either +import qualified Data.Set as Set import Expression +import Hadrian.Oracles.Path (fixUnixPathsOnWindows) +import Oracles.Flavour import Oracles.Setting import Packages +import Rules.Generate (generateSettings) import Settings +import qualified System.Directory.Extra as IO import Settings.Program (programContext) import Target import Utilities -import qualified System.Directory.Extra as IO -import Data.Either -import qualified Data.Set as Set -import Oracles.Flavour -import Rules.Generate (generateSettings) {- Note [Binary distributions] @@ -343,7 +344,25 @@ bindistRules = do ghcRoot <- topDirectory copyFile (ghcRoot -/- "aclocal.m4") (ghcRoot -/- "distrib" -/- "aclocal.m4") copyDirectory (ghcRoot -/- "m4") (ghcRoot -/- "distrib") - buildWithCmdOptions [] $ + + -- Note [Autoreconf unix paths from ACLOCAL_PATH] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- On Windows, autoreconf fails when the ACLOCAL_PATH env variable contains Windows- + -- style paths. This happens because MSYS2 automatically converts env variables to + -- Windows-style paths. To fix this, we convert ACLOCAL_PATH back to Unix style. + -- This is done both in the boot Python script and here when building a bindist. + win_host <- isWinHost + env <- if not win_host + then pure [] + else do + aclocalPathMay <- getEnv "ACLOCAL_PATH" + case aclocalPathMay of + Nothing -> pure [] + Just aclocalPath -> do + unixAclocalPath <- fixUnixPathsOnWindows aclocalPath + pure [AddEnv "ACLOCAL_PATH" unixAclocalPath] + + buildWithCmdOptions env $ target (vanillaContext Stage1 ghc) (Autoreconf $ ghcRoot -/- "distrib") [] [] -- We clean after ourselves, moving the configure script we generated in -- our bindist dir ===================================== libraries/base/changelog.md ===================================== @@ -1,6 +1,7 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) ## 4.24.0.0 *TBA* + * Give `setBit`, `clearBit` and `complementBit` explicit definitions in `instance Bits Integer`, reducing intermediate allocations. ([GHC #21176](https://gitlab.haskell.org/ghc/ghc/-/issues/21176)) * Add `Bounded` instances for `Double`, `Float`, `CDouble` and `CFloat`. ([CLC proposal #402](https://github.com/haskell/core-libraries-committee/issues/402)) * Ensure that `Data.List.elem` and `notElem` can be specialized even when no list fusion happens. ([CLC proposal #412)(https://github.com/haskell/core-libraries-committee/issues/412)) ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs ===================================== @@ -133,6 +133,12 @@ module GHC.Internal.Bignum.Integer , integerBit , integerTestBit# , integerTestBit + , integerSetBit# + , integerSetBit + , integerClearBit# + , integerClearBit + , integerComplementBit# + , integerComplementBit , integerShiftR# , integerShiftR , integerShiftL# @@ -707,6 +713,113 @@ integerTestBit# (IN x) i integerTestBit :: Integer -> Word -> Bool integerTestBit !i (W# n) = isTrue# (integerTestBit# i n) +{- Note [INLINE for constant folding of bit operations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While there are no dedicated constant-folding rules for +integerSetBit#/integerClearBit#/integerComplementBit#, we do INLINE them (and +their Word-argument wrappers and the corresponding Bits Integer methods) to make +the underlying primops accessible for constant folding, e.g. so that +`clearBit (bit 0) 0 :: Integer` folds to `IS 0#`. Test T8832 checks the folding +for all three operations. +-} + +-- | Set the /n/-th bit. +-- +-- Fake 2's complement for negative values (might be slow) +-- +-- @since 10.201.0 +integerSetBit# :: Integer -> Word# -> Integer +{-# INLINE integerSetBit# #-} -- See Note [INLINE for constant folding of bit operations] +integerSetBit# n@(IS x) i + | isTrue# (i `ltWord#` (WORD_SIZE_IN_BITS## `minusWord#` 1##)) + = IS (x `orI#` uncheckedIShiftL# 1# (word2Int# i)) + | isTrue# (x >=# 0#) + = IP (bigNatSetBit# (bigNatFromWord# (int2Word# x)) i) + | True + = n +integerSetBit# (IP x) i = IP (bigNatSetBit# x i) +integerSetBit# (IN x) i = integerFromBigNatNeg# + (bigNatAddWord# + (bigNatClearBit# (bigNatSubWordUnsafe# x 1##) i) + 1##) + +-- | Set the /n/-th bit. +-- +-- Fake 2's complement for negative values (might be slow) +-- +-- @since 10.201.0 +integerSetBit :: Integer -> Word -> Integer +{-# INLINE integerSetBit #-} -- See Note [INLINE for constant folding of bit operations] +integerSetBit !i (W# n) = integerSetBit# i n + +-- | Clear the /n/-th bit. +-- +-- Fake 2's complement for negative values (might be slow) +-- +-- @since 10.201.0 +integerClearBit# :: Integer -> Word# -> Integer +{-# INLINE integerClearBit# #-} -- See Note [INLINE for constant folding of bit operations] +integerClearBit# n@(IS x) i + | isTrue# (i `ltWord#` (WORD_SIZE_IN_BITS## `minusWord#` 1##)) + = IS (x `andI#` notI# (uncheckedIShiftL# 1# (word2Int# i))) + | isTrue# (x >=# 0#) + = n + | True + = IN (bigNatAddWord# + (bigNatSetBit# + (bigNatFromWord# + (minusWord# (int2Word# (negateInt# x)) 1##)) + i) + 1##) +integerClearBit# (IP x) i = integerFromBigNat# (bigNatClearBit# x i) +integerClearBit# (IN x) i = IN (bigNatAddWord# + (bigNatSetBit# (bigNatSubWordUnsafe# x 1##) i) + 1##) + +-- | Clear the /n/-th bit. +-- +-- Fake 2's complement for negative values (might be slow) +-- +-- @since 10.201.0 +integerClearBit :: Integer -> Word -> Integer +{-# INLINE integerClearBit #-} -- See Note [INLINE for constant folding of bit operations] +integerClearBit !i (W# n) = integerClearBit# i n + +-- | Reverse the /n/-th bit. +-- +-- Fake 2's complement for negative values (might be slow) +-- +-- @since 10.201.0 +integerComplementBit# :: Integer -> Word# -> Integer +{-# INLINE integerComplementBit# #-} -- See Note [INLINE for constant folding of bit operations] +integerComplementBit# (IS x) i + | isTrue# (i `ltWord#` (WORD_SIZE_IN_BITS## `minusWord#` 1##)) + = IS (x `xorI#` uncheckedIShiftL# 1# (word2Int# i)) + | isTrue# (x >=# 0#) + = IP (bigNatSetBit# (bigNatFromWord# (int2Word# x)) i) + | True + = IN (bigNatAddWord# + (bigNatSetBit# + (bigNatFromWord# (minusWord# (int2Word# (negateInt# x)) 1##)) + i) + 1##) +integerComplementBit# (IP x) i = integerFromBigNat# (bigNatComplementBit# x i) +integerComplementBit# (IN x) i = integerFromBigNatNeg# + (bigNatAddWord# + (bigNatComplementBit# + (bigNatSubWordUnsafe# x 1##) + i) + 1##) + +-- | Reverse the /n/-th bit. +-- +-- Fake 2's complement for negative values (might be slow) +-- +-- @since 10.201.0 +integerComplementBit :: Integer -> Word -> Integer +{-# INLINE integerComplementBit #-} -- See Note [INLINE for constant folding of bit operations] +integerComplementBit !i (W# n) = integerComplementBit# i n + -- | Shift-right operation -- -- Fake 2's complement for negative values (might be slow) ===================================== libraries/ghc-internal/src/GHC/Internal/Bits.hs ===================================== @@ -564,6 +564,15 @@ instance Bits Integer where | otherwise = integerShiftR x (fromIntegral (negate i)) testBit x i = integerTestBit x (fromIntegral i) zeroBits = integerZero + -- INLINE on setBit/clearBit/complementBit preserves constant folding; + -- see Note [INLINE for constant folding of bit operations] in + -- GHC.Internal.Bignum.Integer. + setBit x i = integerSetBit x (fromIntegral i) + {-# INLINE setBit #-} + clearBit x i = integerClearBit x (fromIntegral i) + {-# INLINE clearBit #-} + complementBit x i = integerComplementBit x (fromIntegral i) + {-# INLINE complementBit #-} bit (I# i) = integerBit# (int2Word# i) popCount x = I# (integerPopCount# x) ===================================== testsuite/driver/runtests.py ===================================== @@ -133,7 +133,7 @@ if args.unexpected_output_dir: config.unexpected_output_dir = Path(args.unexpected_output_dir) if args.only: - config.only = args.only + config.only = set(args.only) config.run_only_some_tests = True if args.skip: ===================================== testsuite/mk/test.mk ===================================== @@ -109,9 +109,11 @@ endif HAVE_GDB := $(shell if gdb --version > /dev/null 2> /dev/null; then echo YES; else echo NO; fi) HAVE_READELF := $(shell if readelf --version > /dev/null 2> /dev/null; then echo YES; else echo NO; fi) -# we need a better way to find which backend is selected and if --check flag is -# used -BIGNUM_GMP := $(shell "$(GHC_PKG)" field ghc-bignum exposed-modules | grep GMP) +# Detect whether the fast (GMP) bignum backend is in use. The GMP backend module +# in ghc-internal is hidden, so we look instead for the gmp library it links +# against: GMP_LIBS adds gmp to ghc-internal's extra-libraries only on a GMP +# build. +BIGNUM_GMP := $(shell "$(GHC_PKG)" field ghc-internal extra-libraries 2>/dev/null | grep gmp) ifeq "$(filter thr, $(GhcRTSWays))" "thr" RUNTEST_OPTS += -e config.ghc_with_threaded_rts=True ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -8371,8 +8371,12 @@ module GHC.Num where integerBit# :: GHC.Internal.Prim.Word# -> Integer integerCheck :: Integer -> GHC.Internal.Types.Bool integerCheck# :: Integer -> GHC.Internal.Bignum.Primitives.Bool# + integerClearBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerClearBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerCompare :: Integer -> Integer -> GHC.Internal.Types.Ordering integerComplement :: Integer -> Integer + integerComplementBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerComplementBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerDecodeDouble# :: GHC.Internal.Prim.Double# -> (# Integer, GHC.Internal.Prim.Int# #) integerDiv :: Integer -> Integer -> Integer integerDivMod :: Integer -> Integer -> (Integer, Integer) @@ -8436,6 +8440,8 @@ module GHC.Num where integerQuotRem# :: Integer -> Integer -> (# Integer, Integer #) integerRecipMod# :: Integer -> Natural -> (# Natural | () #) integerRem :: Integer -> Integer -> Integer + integerSetBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerSetBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftL :: Integer -> GHC.Internal.Types.Word -> Integer integerShiftL# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftR :: Integer -> GHC.Internal.Types.Word -> Integer ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -8409,8 +8409,12 @@ module GHC.Num where integerBit# :: GHC.Internal.Prim.Word# -> Integer integerCheck :: Integer -> GHC.Internal.Types.Bool integerCheck# :: Integer -> GHC.Internal.Bignum.Primitives.Bool# + integerClearBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerClearBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerCompare :: Integer -> Integer -> GHC.Internal.Types.Ordering integerComplement :: Integer -> Integer + integerComplementBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerComplementBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerDecodeDouble# :: GHC.Internal.Prim.Double# -> (# Integer, GHC.Internal.Prim.Int# #) integerDiv :: Integer -> Integer -> Integer integerDivMod :: Integer -> Integer -> (Integer, Integer) @@ -8474,6 +8478,8 @@ module GHC.Num where integerQuotRem# :: Integer -> Integer -> (# Integer, Integer #) integerRecipMod# :: Integer -> Natural -> (# Natural | () #) integerRem :: Integer -> Integer -> Integer + integerSetBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerSetBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftL :: Integer -> GHC.Internal.Types.Word -> Integer integerShiftL# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftR :: Integer -> GHC.Internal.Types.Word -> Integer ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -8589,8 +8589,12 @@ module GHC.Num where integerBit# :: GHC.Internal.Prim.Word# -> Integer integerCheck :: Integer -> GHC.Internal.Types.Bool integerCheck# :: Integer -> GHC.Internal.Bignum.Primitives.Bool# + integerClearBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerClearBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerCompare :: Integer -> Integer -> GHC.Internal.Types.Ordering integerComplement :: Integer -> Integer + integerComplementBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerComplementBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerDecodeDouble# :: GHC.Internal.Prim.Double# -> (# Integer, GHC.Internal.Prim.Int# #) integerDiv :: Integer -> Integer -> Integer integerDivMod :: Integer -> Integer -> (Integer, Integer) @@ -8654,6 +8658,8 @@ module GHC.Num where integerQuotRem# :: Integer -> Integer -> (# Integer, Integer #) integerRecipMod# :: Integer -> Natural -> (# Natural | () #) integerRem :: Integer -> Integer -> Integer + integerSetBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerSetBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftL :: Integer -> GHC.Internal.Types.Word -> Integer integerShiftL# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftR :: Integer -> GHC.Internal.Types.Word -> Integer ===================================== testsuite/tests/interface-stability/ghc-bignum-exports.stdout ===================================== @@ -201,8 +201,12 @@ module GHC.Num.Integer where integerBit# :: GHC.Internal.Prim.Word# -> Integer integerCheck :: Integer -> GHC.Internal.Types.Bool integerCheck# :: Integer -> GHC.Internal.Bignum.Primitives.Bool# + integerClearBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerClearBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerCompare :: Integer -> Integer -> GHC.Internal.Types.Ordering integerComplement :: Integer -> Integer + integerComplementBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerComplementBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerDecodeDouble# :: GHC.Internal.Prim.Double# -> (# Integer, GHC.Internal.Prim.Int# #) integerDiv :: Integer -> Integer -> Integer integerDivMod :: Integer -> Integer -> (Integer, Integer) @@ -266,6 +270,8 @@ module GHC.Num.Integer where integerQuotRem# :: Integer -> Integer -> (# Integer, Integer #) integerRecipMod# :: Integer -> GHC.Internal.Bignum.Natural.Natural -> (# GHC.Internal.Bignum.Natural.Natural | () #) integerRem :: Integer -> Integer -> Integer + integerSetBit :: Integer -> GHC.Internal.Types.Word -> Integer + integerSetBit# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftL :: Integer -> GHC.Internal.Types.Word -> Integer integerShiftL# :: Integer -> GHC.Internal.Prim.Word# -> Integer integerShiftR :: Integer -> GHC.Internal.Types.Word -> Integer ===================================== testsuite/tests/numeric/should_run/T21176.hs ===================================== @@ -0,0 +1,37 @@ +module Main where + +import Data.Bits +import Data.Int (Int32, Int64) +import Data.Foldable (for_) +import GHC.Num.Integer (integerCheck) + +integers :: [Integer] +integers = concatMap neighbours [minInt64, minInt32, 0, maxInt32, maxInt64] + where + neighbours i = [i - 2, i - 1, i, i + 1, i + 2] + minInt64 = toInteger (minBound :: Int64) + minInt32 = toInteger (minBound :: Int32) + maxInt32 = toInteger (maxBound :: Int32) + maxInt64 = toInteger (maxBound :: Int64) + +bits :: [Int] +bits = [0, 1, 62, 63, 64] + +testXBit :: String -> (Integer -> Int -> Integer) -> (Integer -> Int -> Integer) -> IO () +testXBit name f model = do + putStrLn name + for_ integers $ \i -> + for_ bits $ \b -> do + let actual = f i b + expected = model i b + valid = if integerCheck actual then "valid" else "invalid" + matches = if actual == expected then "matches" else "differs" + putStrLn $ " " ++ show i ++ " " ++ show b ++ " -> " ++ show actual + ++ " [" ++ valid ++ ", " ++ matches ++ "]" + putStrLn "" + +main :: IO () +main = do + testXBit "setBit" setBit (\i b -> i .|. bit b) + testXBit "clearBit" clearBit (\i b -> i .&. complement (bit b)) + testXBit "complementBit" complementBit (\i b -> i `xor` bit b) ===================================== testsuite/tests/numeric/should_run/T21176.stdout ===================================== @@ -0,0 +1,381 @@ +setBit + -9223372036854775810 0 -> -9223372036854775809 [valid, matches] + -9223372036854775810 1 -> -9223372036854775810 [valid, matches] + -9223372036854775810 62 -> -9223372036854775810 [valid, matches] + -9223372036854775810 63 -> -2 [valid, matches] + -9223372036854775810 64 -> -9223372036854775810 [valid, matches] + -9223372036854775809 0 -> -9223372036854775809 [valid, matches] + -9223372036854775809 1 -> -9223372036854775809 [valid, matches] + -9223372036854775809 62 -> -9223372036854775809 [valid, matches] + -9223372036854775809 63 -> -1 [valid, matches] + -9223372036854775809 64 -> -9223372036854775809 [valid, matches] + -9223372036854775808 0 -> -9223372036854775807 [valid, matches] + -9223372036854775808 1 -> -9223372036854775806 [valid, matches] + -9223372036854775808 62 -> -4611686018427387904 [valid, matches] + -9223372036854775808 63 -> -9223372036854775808 [valid, matches] + -9223372036854775808 64 -> -9223372036854775808 [valid, matches] + -9223372036854775807 0 -> -9223372036854775807 [valid, matches] + -9223372036854775807 1 -> -9223372036854775805 [valid, matches] + -9223372036854775807 62 -> -4611686018427387903 [valid, matches] + -9223372036854775807 63 -> -9223372036854775807 [valid, matches] + -9223372036854775807 64 -> -9223372036854775807 [valid, matches] + -9223372036854775806 0 -> -9223372036854775805 [valid, matches] + -9223372036854775806 1 -> -9223372036854775806 [valid, matches] + -9223372036854775806 62 -> -4611686018427387902 [valid, matches] + -9223372036854775806 63 -> -9223372036854775806 [valid, matches] + -9223372036854775806 64 -> -9223372036854775806 [valid, matches] + -2147483650 0 -> -2147483649 [valid, matches] + -2147483650 1 -> -2147483650 [valid, matches] + -2147483650 62 -> -2147483650 [valid, matches] + -2147483650 63 -> -2147483650 [valid, matches] + -2147483650 64 -> -2147483650 [valid, matches] + -2147483649 0 -> -2147483649 [valid, matches] + -2147483649 1 -> -2147483649 [valid, matches] + -2147483649 62 -> -2147483649 [valid, matches] + -2147483649 63 -> -2147483649 [valid, matches] + -2147483649 64 -> -2147483649 [valid, matches] + -2147483648 0 -> -2147483647 [valid, matches] + -2147483648 1 -> -2147483646 [valid, matches] + -2147483648 62 -> -2147483648 [valid, matches] + -2147483648 63 -> -2147483648 [valid, matches] + -2147483648 64 -> -2147483648 [valid, matches] + -2147483647 0 -> -2147483647 [valid, matches] + -2147483647 1 -> -2147483645 [valid, matches] + -2147483647 62 -> -2147483647 [valid, matches] + -2147483647 63 -> -2147483647 [valid, matches] + -2147483647 64 -> -2147483647 [valid, matches] + -2147483646 0 -> -2147483645 [valid, matches] + -2147483646 1 -> -2147483646 [valid, matches] + -2147483646 62 -> -2147483646 [valid, matches] + -2147483646 63 -> -2147483646 [valid, matches] + -2147483646 64 -> -2147483646 [valid, matches] + -2 0 -> -1 [valid, matches] + -2 1 -> -2 [valid, matches] + -2 62 -> -2 [valid, matches] + -2 63 -> -2 [valid, matches] + -2 64 -> -2 [valid, matches] + -1 0 -> -1 [valid, matches] + -1 1 -> -1 [valid, matches] + -1 62 -> -1 [valid, matches] + -1 63 -> -1 [valid, matches] + -1 64 -> -1 [valid, matches] + 0 0 -> 1 [valid, matches] + 0 1 -> 2 [valid, matches] + 0 62 -> 4611686018427387904 [valid, matches] + 0 63 -> 9223372036854775808 [valid, matches] + 0 64 -> 18446744073709551616 [valid, matches] + 1 0 -> 1 [valid, matches] + 1 1 -> 3 [valid, matches] + 1 62 -> 4611686018427387905 [valid, matches] + 1 63 -> 9223372036854775809 [valid, matches] + 1 64 -> 18446744073709551617 [valid, matches] + 2 0 -> 3 [valid, matches] + 2 1 -> 2 [valid, matches] + 2 62 -> 4611686018427387906 [valid, matches] + 2 63 -> 9223372036854775810 [valid, matches] + 2 64 -> 18446744073709551618 [valid, matches] + 2147483645 0 -> 2147483645 [valid, matches] + 2147483645 1 -> 2147483647 [valid, matches] + 2147483645 62 -> 4611686020574871549 [valid, matches] + 2147483645 63 -> 9223372039002259453 [valid, matches] + 2147483645 64 -> 18446744075857035261 [valid, matches] + 2147483646 0 -> 2147483647 [valid, matches] + 2147483646 1 -> 2147483646 [valid, matches] + 2147483646 62 -> 4611686020574871550 [valid, matches] + 2147483646 63 -> 9223372039002259454 [valid, matches] + 2147483646 64 -> 18446744075857035262 [valid, matches] + 2147483647 0 -> 2147483647 [valid, matches] + 2147483647 1 -> 2147483647 [valid, matches] + 2147483647 62 -> 4611686020574871551 [valid, matches] + 2147483647 63 -> 9223372039002259455 [valid, matches] + 2147483647 64 -> 18446744075857035263 [valid, matches] + 2147483648 0 -> 2147483649 [valid, matches] + 2147483648 1 -> 2147483650 [valid, matches] + 2147483648 62 -> 4611686020574871552 [valid, matches] + 2147483648 63 -> 9223372039002259456 [valid, matches] + 2147483648 64 -> 18446744075857035264 [valid, matches] + 2147483649 0 -> 2147483649 [valid, matches] + 2147483649 1 -> 2147483651 [valid, matches] + 2147483649 62 -> 4611686020574871553 [valid, matches] + 2147483649 63 -> 9223372039002259457 [valid, matches] + 2147483649 64 -> 18446744075857035265 [valid, matches] + 9223372036854775805 0 -> 9223372036854775805 [valid, matches] + 9223372036854775805 1 -> 9223372036854775807 [valid, matches] + 9223372036854775805 62 -> 9223372036854775805 [valid, matches] + 9223372036854775805 63 -> 18446744073709551613 [valid, matches] + 9223372036854775805 64 -> 27670116110564327421 [valid, matches] + 9223372036854775806 0 -> 9223372036854775807 [valid, matches] + 9223372036854775806 1 -> 9223372036854775806 [valid, matches] + 9223372036854775806 62 -> 9223372036854775806 [valid, matches] + 9223372036854775806 63 -> 18446744073709551614 [valid, matches] + 9223372036854775806 64 -> 27670116110564327422 [valid, matches] + 9223372036854775807 0 -> 9223372036854775807 [valid, matches] + 9223372036854775807 1 -> 9223372036854775807 [valid, matches] + 9223372036854775807 62 -> 9223372036854775807 [valid, matches] + 9223372036854775807 63 -> 18446744073709551615 [valid, matches] + 9223372036854775807 64 -> 27670116110564327423 [valid, matches] + 9223372036854775808 0 -> 9223372036854775809 [valid, matches] + 9223372036854775808 1 -> 9223372036854775810 [valid, matches] + 9223372036854775808 62 -> 13835058055282163712 [valid, matches] + 9223372036854775808 63 -> 9223372036854775808 [valid, matches] + 9223372036854775808 64 -> 27670116110564327424 [valid, matches] + 9223372036854775809 0 -> 9223372036854775809 [valid, matches] + 9223372036854775809 1 -> 9223372036854775811 [valid, matches] + 9223372036854775809 62 -> 13835058055282163713 [valid, matches] + 9223372036854775809 63 -> 9223372036854775809 [valid, matches] + 9223372036854775809 64 -> 27670116110564327425 [valid, matches] + +clearBit + -9223372036854775810 0 -> -9223372036854775810 [valid, matches] + -9223372036854775810 1 -> -9223372036854775812 [valid, matches] + -9223372036854775810 62 -> -13835058055282163714 [valid, matches] + -9223372036854775810 63 -> -9223372036854775810 [valid, matches] + -9223372036854775810 64 -> -27670116110564327426 [valid, matches] + -9223372036854775809 0 -> -9223372036854775810 [valid, matches] + -9223372036854775809 1 -> -9223372036854775811 [valid, matches] + -9223372036854775809 62 -> -13835058055282163713 [valid, matches] + -9223372036854775809 63 -> -9223372036854775809 [valid, matches] + -9223372036854775809 64 -> -27670116110564327425 [valid, matches] + -9223372036854775808 0 -> -9223372036854775808 [valid, matches] + -9223372036854775808 1 -> -9223372036854775808 [valid, matches] + -9223372036854775808 62 -> -9223372036854775808 [valid, matches] + -9223372036854775808 63 -> -18446744073709551616 [valid, matches] + -9223372036854775808 64 -> -27670116110564327424 [valid, matches] + -9223372036854775807 0 -> -9223372036854775808 [valid, matches] + -9223372036854775807 1 -> -9223372036854775807 [valid, matches] + -9223372036854775807 62 -> -9223372036854775807 [valid, matches] + -9223372036854775807 63 -> -18446744073709551615 [valid, matches] + -9223372036854775807 64 -> -27670116110564327423 [valid, matches] + -9223372036854775806 0 -> -9223372036854775806 [valid, matches] + -9223372036854775806 1 -> -9223372036854775808 [valid, matches] + -9223372036854775806 62 -> -9223372036854775806 [valid, matches] + -9223372036854775806 63 -> -18446744073709551614 [valid, matches] + -9223372036854775806 64 -> -27670116110564327422 [valid, matches] + -2147483650 0 -> -2147483650 [valid, matches] + -2147483650 1 -> -2147483652 [valid, matches] + -2147483650 62 -> -4611686020574871554 [valid, matches] + -2147483650 63 -> -9223372039002259458 [valid, matches] + -2147483650 64 -> -18446744075857035266 [valid, matches] + -2147483649 0 -> -2147483650 [valid, matches] + -2147483649 1 -> -2147483651 [valid, matches] + -2147483649 62 -> -4611686020574871553 [valid, matches] + -2147483649 63 -> -9223372039002259457 [valid, matches] + -2147483649 64 -> -18446744075857035265 [valid, matches] + -2147483648 0 -> -2147483648 [valid, matches] + -2147483648 1 -> -2147483648 [valid, matches] + -2147483648 62 -> -4611686020574871552 [valid, matches] + -2147483648 63 -> -9223372039002259456 [valid, matches] + -2147483648 64 -> -18446744075857035264 [valid, matches] + -2147483647 0 -> -2147483648 [valid, matches] + -2147483647 1 -> -2147483647 [valid, matches] + -2147483647 62 -> -4611686020574871551 [valid, matches] + -2147483647 63 -> -9223372039002259455 [valid, matches] + -2147483647 64 -> -18446744075857035263 [valid, matches] + -2147483646 0 -> -2147483646 [valid, matches] + -2147483646 1 -> -2147483648 [valid, matches] + -2147483646 62 -> -4611686020574871550 [valid, matches] + -2147483646 63 -> -9223372039002259454 [valid, matches] + -2147483646 64 -> -18446744075857035262 [valid, matches] + -2 0 -> -2 [valid, matches] + -2 1 -> -4 [valid, matches] + -2 62 -> -4611686018427387906 [valid, matches] + -2 63 -> -9223372036854775810 [valid, matches] + -2 64 -> -18446744073709551618 [valid, matches] + -1 0 -> -2 [valid, matches] + -1 1 -> -3 [valid, matches] + -1 62 -> -4611686018427387905 [valid, matches] + -1 63 -> -9223372036854775809 [valid, matches] + -1 64 -> -18446744073709551617 [valid, matches] + 0 0 -> 0 [valid, matches] + 0 1 -> 0 [valid, matches] + 0 62 -> 0 [valid, matches] + 0 63 -> 0 [valid, matches] + 0 64 -> 0 [valid, matches] + 1 0 -> 0 [valid, matches] + 1 1 -> 1 [valid, matches] + 1 62 -> 1 [valid, matches] + 1 63 -> 1 [valid, matches] + 1 64 -> 1 [valid, matches] + 2 0 -> 2 [valid, matches] + 2 1 -> 0 [valid, matches] + 2 62 -> 2 [valid, matches] + 2 63 -> 2 [valid, matches] + 2 64 -> 2 [valid, matches] + 2147483645 0 -> 2147483644 [valid, matches] + 2147483645 1 -> 2147483645 [valid, matches] + 2147483645 62 -> 2147483645 [valid, matches] + 2147483645 63 -> 2147483645 [valid, matches] + 2147483645 64 -> 2147483645 [valid, matches] + 2147483646 0 -> 2147483646 [valid, matches] + 2147483646 1 -> 2147483644 [valid, matches] + 2147483646 62 -> 2147483646 [valid, matches] + 2147483646 63 -> 2147483646 [valid, matches] + 2147483646 64 -> 2147483646 [valid, matches] + 2147483647 0 -> 2147483646 [valid, matches] + 2147483647 1 -> 2147483645 [valid, matches] + 2147483647 62 -> 2147483647 [valid, matches] + 2147483647 63 -> 2147483647 [valid, matches] + 2147483647 64 -> 2147483647 [valid, matches] + 2147483648 0 -> 2147483648 [valid, matches] + 2147483648 1 -> 2147483648 [valid, matches] + 2147483648 62 -> 2147483648 [valid, matches] + 2147483648 63 -> 2147483648 [valid, matches] + 2147483648 64 -> 2147483648 [valid, matches] + 2147483649 0 -> 2147483648 [valid, matches] + 2147483649 1 -> 2147483649 [valid, matches] + 2147483649 62 -> 2147483649 [valid, matches] + 2147483649 63 -> 2147483649 [valid, matches] + 2147483649 64 -> 2147483649 [valid, matches] + 9223372036854775805 0 -> 9223372036854775804 [valid, matches] + 9223372036854775805 1 -> 9223372036854775805 [valid, matches] + 9223372036854775805 62 -> 4611686018427387901 [valid, matches] + 9223372036854775805 63 -> 9223372036854775805 [valid, matches] + 9223372036854775805 64 -> 9223372036854775805 [valid, matches] + 9223372036854775806 0 -> 9223372036854775806 [valid, matches] + 9223372036854775806 1 -> 9223372036854775804 [valid, matches] + 9223372036854775806 62 -> 4611686018427387902 [valid, matches] + 9223372036854775806 63 -> 9223372036854775806 [valid, matches] + 9223372036854775806 64 -> 9223372036854775806 [valid, matches] + 9223372036854775807 0 -> 9223372036854775806 [valid, matches] + 9223372036854775807 1 -> 9223372036854775805 [valid, matches] + 9223372036854775807 62 -> 4611686018427387903 [valid, matches] + 9223372036854775807 63 -> 9223372036854775807 [valid, matches] + 9223372036854775807 64 -> 9223372036854775807 [valid, matches] + 9223372036854775808 0 -> 9223372036854775808 [valid, matches] + 9223372036854775808 1 -> 9223372036854775808 [valid, matches] + 9223372036854775808 62 -> 9223372036854775808 [valid, matches] + 9223372036854775808 63 -> 0 [valid, matches] + 9223372036854775808 64 -> 9223372036854775808 [valid, matches] + 9223372036854775809 0 -> 9223372036854775808 [valid, matches] + 9223372036854775809 1 -> 9223372036854775809 [valid, matches] + 9223372036854775809 62 -> 9223372036854775809 [valid, matches] + 9223372036854775809 63 -> 1 [valid, matches] + 9223372036854775809 64 -> 9223372036854775809 [valid, matches] + +complementBit + -9223372036854775810 0 -> -9223372036854775809 [valid, matches] + -9223372036854775810 1 -> -9223372036854775812 [valid, matches] + -9223372036854775810 62 -> -13835058055282163714 [valid, matches] + -9223372036854775810 63 -> -2 [valid, matches] + -9223372036854775810 64 -> -27670116110564327426 [valid, matches] + -9223372036854775809 0 -> -9223372036854775810 [valid, matches] + -9223372036854775809 1 -> -9223372036854775811 [valid, matches] + -9223372036854775809 62 -> -13835058055282163713 [valid, matches] + -9223372036854775809 63 -> -1 [valid, matches] + -9223372036854775809 64 -> -27670116110564327425 [valid, matches] + -9223372036854775808 0 -> -9223372036854775807 [valid, matches] + -9223372036854775808 1 -> -9223372036854775806 [valid, matches] + -9223372036854775808 62 -> -4611686018427387904 [valid, matches] + -9223372036854775808 63 -> -18446744073709551616 [valid, matches] + -9223372036854775808 64 -> -27670116110564327424 [valid, matches] + -9223372036854775807 0 -> -9223372036854775808 [valid, matches] + -9223372036854775807 1 -> -9223372036854775805 [valid, matches] + -9223372036854775807 62 -> -4611686018427387903 [valid, matches] + -9223372036854775807 63 -> -18446744073709551615 [valid, matches] + -9223372036854775807 64 -> -27670116110564327423 [valid, matches] + -9223372036854775806 0 -> -9223372036854775805 [valid, matches] + -9223372036854775806 1 -> -9223372036854775808 [valid, matches] + -9223372036854775806 62 -> -4611686018427387902 [valid, matches] + -9223372036854775806 63 -> -18446744073709551614 [valid, matches] + -9223372036854775806 64 -> -27670116110564327422 [valid, matches] + -2147483650 0 -> -2147483649 [valid, matches] + -2147483650 1 -> -2147483652 [valid, matches] + -2147483650 62 -> -4611686020574871554 [valid, matches] + -2147483650 63 -> -9223372039002259458 [valid, matches] + -2147483650 64 -> -18446744075857035266 [valid, matches] + -2147483649 0 -> -2147483650 [valid, matches] + -2147483649 1 -> -2147483651 [valid, matches] + -2147483649 62 -> -4611686020574871553 [valid, matches] + -2147483649 63 -> -9223372039002259457 [valid, matches] + -2147483649 64 -> -18446744075857035265 [valid, matches] + -2147483648 0 -> -2147483647 [valid, matches] + -2147483648 1 -> -2147483646 [valid, matches] + -2147483648 62 -> -4611686020574871552 [valid, matches] + -2147483648 63 -> -9223372039002259456 [valid, matches] + -2147483648 64 -> -18446744075857035264 [valid, matches] + -2147483647 0 -> -2147483648 [valid, matches] + -2147483647 1 -> -2147483645 [valid, matches] + -2147483647 62 -> -4611686020574871551 [valid, matches] + -2147483647 63 -> -9223372039002259455 [valid, matches] + -2147483647 64 -> -18446744075857035263 [valid, matches] + -2147483646 0 -> -2147483645 [valid, matches] + -2147483646 1 -> -2147483648 [valid, matches] + -2147483646 62 -> -4611686020574871550 [valid, matches] + -2147483646 63 -> -9223372039002259454 [valid, matches] + -2147483646 64 -> -18446744075857035262 [valid, matches] + -2 0 -> -1 [valid, matches] + -2 1 -> -4 [valid, matches] + -2 62 -> -4611686018427387906 [valid, matches] + -2 63 -> -9223372036854775810 [valid, matches] + -2 64 -> -18446744073709551618 [valid, matches] + -1 0 -> -2 [valid, matches] + -1 1 -> -3 [valid, matches] + -1 62 -> -4611686018427387905 [valid, matches] + -1 63 -> -9223372036854775809 [valid, matches] + -1 64 -> -18446744073709551617 [valid, matches] + 0 0 -> 1 [valid, matches] + 0 1 -> 2 [valid, matches] + 0 62 -> 4611686018427387904 [valid, matches] + 0 63 -> 9223372036854775808 [valid, matches] + 0 64 -> 18446744073709551616 [valid, matches] + 1 0 -> 0 [valid, matches] + 1 1 -> 3 [valid, matches] + 1 62 -> 4611686018427387905 [valid, matches] + 1 63 -> 9223372036854775809 [valid, matches] + 1 64 -> 18446744073709551617 [valid, matches] + 2 0 -> 3 [valid, matches] + 2 1 -> 0 [valid, matches] + 2 62 -> 4611686018427387906 [valid, matches] + 2 63 -> 9223372036854775810 [valid, matches] + 2 64 -> 18446744073709551618 [valid, matches] + 2147483645 0 -> 2147483644 [valid, matches] + 2147483645 1 -> 2147483647 [valid, matches] + 2147483645 62 -> 4611686020574871549 [valid, matches] + 2147483645 63 -> 9223372039002259453 [valid, matches] + 2147483645 64 -> 18446744075857035261 [valid, matches] + 2147483646 0 -> 2147483647 [valid, matches] + 2147483646 1 -> 2147483644 [valid, matches] + 2147483646 62 -> 4611686020574871550 [valid, matches] + 2147483646 63 -> 9223372039002259454 [valid, matches] + 2147483646 64 -> 18446744075857035262 [valid, matches] + 2147483647 0 -> 2147483646 [valid, matches] + 2147483647 1 -> 2147483645 [valid, matches] + 2147483647 62 -> 4611686020574871551 [valid, matches] + 2147483647 63 -> 9223372039002259455 [valid, matches] + 2147483647 64 -> 18446744075857035263 [valid, matches] + 2147483648 0 -> 2147483649 [valid, matches] + 2147483648 1 -> 2147483650 [valid, matches] + 2147483648 62 -> 4611686020574871552 [valid, matches] + 2147483648 63 -> 9223372039002259456 [valid, matches] + 2147483648 64 -> 18446744075857035264 [valid, matches] + 2147483649 0 -> 2147483648 [valid, matches] + 2147483649 1 -> 2147483651 [valid, matches] + 2147483649 62 -> 4611686020574871553 [valid, matches] + 2147483649 63 -> 9223372039002259457 [valid, matches] + 2147483649 64 -> 18446744075857035265 [valid, matches] + 9223372036854775805 0 -> 9223372036854775804 [valid, matches] + 9223372036854775805 1 -> 9223372036854775807 [valid, matches] + 9223372036854775805 62 -> 4611686018427387901 [valid, matches] + 9223372036854775805 63 -> 18446744073709551613 [valid, matches] + 9223372036854775805 64 -> 27670116110564327421 [valid, matches] + 9223372036854775806 0 -> 9223372036854775807 [valid, matches] + 9223372036854775806 1 -> 9223372036854775804 [valid, matches] + 9223372036854775806 62 -> 4611686018427387902 [valid, matches] + 9223372036854775806 63 -> 18446744073709551614 [valid, matches] + 9223372036854775806 64 -> 27670116110564327422 [valid, matches] + 9223372036854775807 0 -> 9223372036854775806 [valid, matches] + 9223372036854775807 1 -> 9223372036854775805 [valid, matches] + 9223372036854775807 62 -> 4611686018427387903 [valid, matches] + 9223372036854775807 63 -> 18446744073709551615 [valid, matches] + 9223372036854775807 64 -> 27670116110564327423 [valid, matches] + 9223372036854775808 0 -> 9223372036854775809 [valid, matches] + 9223372036854775808 1 -> 9223372036854775810 [valid, matches] + 9223372036854775808 62 -> 13835058055282163712 [valid, matches] + 9223372036854775808 63 -> 0 [valid, matches] + 9223372036854775808 64 -> 27670116110564327424 [valid, matches] + 9223372036854775809 0 -> 9223372036854775808 [valid, matches] + 9223372036854775809 1 -> 9223372036854775811 [valid, matches] + 9223372036854775809 62 -> 13835058055282163713 [valid, matches] + 9223372036854775809 63 -> 1 [valid, matches] + 9223372036854775809 64 -> 27670116110564327425 [valid, matches] + ===================================== testsuite/tests/numeric/should_run/all.T ===================================== @@ -101,3 +101,4 @@ test('T24245', normal, compile_and_run, ['']) test('T25653', normal, compile_and_run, ['']) test('T18619', exit_code(1), compile_and_run, ['']) test('T26230', normal, compile_and_run, ['']) +test('T21176', normal, compile_and_run, ['']) ===================================== testsuite/tests/simplCore/should_compile/T8832.hs ===================================== @@ -23,3 +23,9 @@ T(w32,Word32) T(w64,Word64) T(z,Integer) + +zset :: Integer +zset = setBit (bit 0) 0 + +zcompl :: Integer +zcompl = complementBit (bit 0) 0 ===================================== testsuite/tests/simplCore/should_compile/T8832.stdout ===================================== @@ -8,4 +8,6 @@ w8 = GHC.Internal.Word.W8# 0#Word8 w16 = GHC.Internal.Word.W16# 0#Word16 w32 = GHC.Internal.Word.W32# 0#Word32 w64 = GHC.Internal.Word.W64# 0#Word64 -z = GHC.Internal.Bignum.Integer.IS 0# +zcompl = GHC.Internal.Bignum.Integer.IS 0# +zset = GHC.Internal.Bignum.Integer.IS 1# +z = zcompl ===================================== utils/check-exact/Main.hs ===================================== @@ -646,7 +646,7 @@ addLocaLDecl3 :: Changer addLocaLDecl3 libdir top = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let - doAddLocal = replaceDecls (anchorEof lp) [parent',d2'] + doAddLocal = replaceDecls (addModuleCommentOrigDeltas lp) [parent',d2'] where lp = top (de1:d2:_) = hsDecls lp @@ -667,7 +667,7 @@ addLocaLDecl4 libdir lp = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") Right newSig <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") let - doAddLocal = replaceDecls (anchorEof lp) (parent':ds) + doAddLocal = replaceDecls (addModuleCommentOrigDeltas lp) (parent':ds) where (parent:ds) = hsDecls (makeDeltaAst lp) @@ -781,7 +781,7 @@ rmDecl3 _libdir lp = do rmDecl4 :: Changer rmDecl4 _libdir lp = do let - doRmDecl = replaceDecls (anchorEof lp) [de1',sd1] + doRmDecl = replaceDecls (addModuleCommentOrigDeltas lp) [de1',sd1] where [de1] = hsDecls lp (de1',Just sd1) = modifyValD (getLocA de1) de1 $ \_m [sd1a,sd2] -> ===================================== utils/check-exact/Transform.hs ===================================== @@ -65,7 +65,7 @@ module Transform , balanceComments , balanceCommentsList , balanceCommentsListA - , anchorEof + , addModuleCommentOrigDeltas -- ** Managing lists, pure functions , captureOrderBinds @@ -724,8 +724,8 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) -- --------------------------------------------------------------------- -anchorEof :: ParsedSource -> ParsedSource -anchorEof (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } }) +addModuleCommentOrigDeltas :: ParsedSource -> ParsedSource +addModuleCommentOrigDeltas (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } }) where an' = addCommentOrigDeltasAnn an View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ca4a699ffefb5cfc6784097a51fb73… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ca4a699ffefb5cfc6784097a51fb73… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/textual-bytecode-output] Work in progress on #26909
by Wolfgang Jeltsch (＠jeltsch) 09 Jun '26

09 Jun '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/textual-bytecode-output at Glasgow Haskell Compiler / GHC Commits: c3a2f8c1 by Wolfgang Jeltsch at 2026-06-09T14:36:01+03:00 Work in progress on #26909 - - - - - 6 changed files: - compiler/GHC/ByteCode/Serialize.hs - + compiler/GHC/ByteCode/Show.hs - compiler/ghc.cabal.in - ghc/GHC/Driver/Session/Mode.hs - ghc/Main.hs - libraries/ghci/GHCi/ResolvedBCO.hs Changes: ===================================== compiler/GHC/ByteCode/Serialize.hs ===================================== @@ -6,7 +6,7 @@ {- | This module implements the serialization of bytecode objects to and from disk. -} module GHC.ByteCode.Serialize - ( writeBinByteCode, readBinByteCode + ( writeBinByteCode, readBinByteCode, readOnDiskModuleByteCode , ModuleByteCode(..) , BytecodeLibX(..) , BytecodeLib ===================================== compiler/GHC/ByteCode/Show.hs ===================================== @@ -0,0 +1,566 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | […] +module GHC.ByteCode.Show (showByteCode) where + +import Prelude ((+), (-), Integral, div) +import Control.Applicative ((<$>), (<*>)) +import Control.Arrow ((>>>)) +import Control.Exception (assert) +import Data.Eq ((==)) +import Data.Bits (FiniteBits, finiteBitSize) +import Data.Function (($), id, (.)) +import Data.Tuple (fst, snd, uncurry) +import Data.Bool (Bool, otherwise, not, (&&)) +import Data.Int (Int) +import Data.Word (Word, Word16) +import Data.Maybe (Maybe, maybe) +import Data.Either (Either, either) +import Data.List (length, (++), map, zipWith, take, drop, replicate) +import Data.String (String) +import Data.ByteString (ByteString, unpack) +import Data.ByteString.Short (ShortByteString) +import Data.IntMap (IntMap) +import Data.IntMap qualified as IntMap (toList) +import Data.Array.IArray (IArray, bounds, indices, elems) +import Data.Array.Unboxed (UArray) +import Numeric (showHex) +import Text.Show (show) +import System.IO (IO, FilePath) +import Foreign.Storable (Storable) +import GHC.Data.Strict qualified as Strict (Maybe, maybe) +import GHC.Data.FastString (unpackFS) +import GHC.Data.FlatBag (FlatBag, elemsFlatBag) +import GHC.Fingerprint (Fingerprint) +import GHC.Types.SrcLoc (noSrcSpan) +import GHC.Types.Name (Name) +import GHC.Types.Name.Occurrence (OccName) +import GHC.Types.Tickish (BreakTickIndex, BreakpointId (..)) +import GHC.Types.SptEntry (SptEntry (..)) +import GHC.Types.Error (MessageClass (MCDump)) +import GHC.Utils.Logger (Logger, logMsg) +import GHC.Utils.Binary (BinSrcSpan (..)) +import GHC.Utils.Encoding.UTF8 (utf8DecodeShortByteString, utf8DecodeByteString) +import GHC.Utils.Outputable + ( + defaultDumpStyle, + SDoc, + text, + (<>), + (<+>), + hsep, + vcat, + hang, + withPprStyle, + ppr + ) +import GHC.Unit.Types (Module) +import GHC.Iface.Type (IfaceType, IfaceTvBndr, IfaceIdBndr) +import GHC.HsToCore.Breakpoints (ModBreaks (..)) +import GHC.ByteCode.Types + ( + FFIInfo (..), + BCONPtr (..), + BCOPtr (..), + UnlinkedBCO (..), + ByteCodeHpcInfo (..), + CompiledByteCode (..) + ) +import GHC.ByteCode.Breakpoints + ( + InternalBreakpointId (..), + InternalBreakLoc (..), + CgBreakInfo (..), + InternalModBreaks (..) + ) +import GHC.ByteCode.Binary (OnDiskModuleByteCode (..)) +import GHC.ByteCode.Serialize (readOnDiskModuleByteCode) +import GHC.Driver.Env.Types (HscEnv) +import GHCi.ResolvedBCO (BCOByteArray, fromBCOByteArray) +import GHCi.FFI (FFIType) +import GHCi.Message (ConInfoTable (..)) + +-- | […] +showByteCode :: Logger -> HscEnv -> FilePath -> IO () +showByteCode logger env path = do + byteCode <- readOnDiskModuleByteCode env path + logMsg logger + MCDump + noSrcSpan + (withPprStyle defaultDumpStyle $ pprOnDiskModuleByteCode byteCode) + +-- | […] +pprOnDiskModuleByteCode :: OnDiskModuleByteCode -> SDoc +pprOnDiskModuleByteCode OnDiskModuleByteCode {..} + = entry (text "module" <+> ppr odgbc_module) $ + vcat [ + pprOnDiskModuleByteCodeHash $ odgbc_hash, + pprCompiledByteCode odgbc_module $ odgbc_compiled_byte_code, + pprObjectFileContents $ odgbc_foreign + ] + +-- | […] +pprOnDiskModuleByteCodeHash :: Fingerprint -> SDoc +pprOnDiskModuleByteCodeHash = entry (text "hash:") . ppr + +-- | […] +pprCompiledByteCode :: Module -> CompiledByteCode -> SDoc +pprCompiledByteCode currentModule CompiledByteCode {..} + = entry (text "compiled bytecode:") $ + vcat [ + pprByteCodeObjects currentModule $ bc_bcos, + pprDataConstructorInfoTables $ bc_itbls, + pprTopLevelStrings $ bc_strs, + pprBreakpoints currentModule $ bc_breaks, + pprStaticPointerTableEntries $ bc_spt_entries, + pprHPCInfo $ bc_hpc_info + ] + +-- | […] +pprByteCodeObjects :: Module -> FlatBag UnlinkedBCO -> SDoc +pprByteCodeObjects currentModule = entry (text "bytecode objects:") . + vcatOrNone . + map (pprByteCodeObject currentModule) . + elemsFlatBag + +-- | […] +pprByteCodeObject :: Module -> UnlinkedBCO -> SDoc +pprByteCodeObject currentModule byteCodeObject = case byteCodeObject of + UnlinkedBCO {..} + -> entry (text "ordinary object" <+> ppr unlinkedBCOName <> text ":") $ + vcat [ + pprArity $ unlinkedBCOArity, + pprInstructions $ unlinkedBCOInstrs, + pprBitmap $ unlinkedBCOBitmap, + pprLiterals currentModule $ unlinkedBCOLits, + pprPointers currentModule $ unlinkedBCOPtrs + ] + UnlinkedStaticCon {..} + -> entry ( + text "static-construction object" <+> + ppr unlinkedStaticConName <> + text ":" + ) + $ + vcat [ + pprDataConstructorName $ unlinkedStaticConDataConName, + pprLiftedness $ not unlinkedStaticConIsUnlifted, + pprLiterals currentModule $ unlinkedStaticConLits, + pprPointers currentModule $ unlinkedStaticConPtrs + ] + +-- | […] +pprArity :: Int -> SDoc +pprArity = entry (text "arity:") . ppr + +-- | […] +pprInstructions :: BCOByteArray Word16 -> SDoc +pprInstructions = entry (text "instructions:") . pprBCOByteArray + +-- | […] +pprBitmap :: BCOByteArray Word -> SDoc +pprBitmap = entry (text "bitmap:") . pprBCOByteArray + +-- | […] +pprDataConstructorName :: Name -> SDoc +pprDataConstructorName = entry (text "data constructor name:") . ppr + +-- | […] +pprLiftedness :: Bool -> SDoc +pprLiftedness = entry (text "lifted:") . noOrYes + +-- | […] +pprLiterals :: Module -> FlatBag BCONPtr -> SDoc +pprLiterals currentModule = entry (text "literals:") . + vcatOrNone . + map (pprLiteral currentModule) . + elemsFlatBag + +-- | […] +pprLiteral :: Module -> BCONPtr -> SDoc +pprLiteral currentModule literal = case literal of + BCONPtrWord word + -> text "word" <+> + pprFixedSizeNatural word + BCONPtrLbl label + -> text "label" <+> + ppr label + BCONPtrItbl infoTableName + -> text "info table" <+> + ppr infoTableName + BCONPtrAddr addrName + -> text "address" <+> + ppr addrName + BCONPtrStr encodedString + -> text "top-level string" <+> + text (show (utf8DecodeByteString encodedString)) + BCONPtrFS string + -> text "top-level string" <+> + text (show (unpackFS string)) + BCONPtrFFIInfo ffiInfo + -> text "foreign function" <+> + pprFFIInfo ffiInfo + BCONPtrCostCentre breakpointID + -> text "cost center" <+> + pprInternalBreakpointID currentModule breakpointID + +-- | […] +pprFFIInfo :: FFIInfo -> SDoc +pprFFIInfo FFIInfo {..} + = hsep (map (pprFFIType >>> (<+> text "->")) ffiInfoArgs) <+> + pprFFIType ffiInfoRet + +-- | […] +pprFFIType :: FFIType -> SDoc +pprFFIType ffiType = assert (take 3 ident == "FFI") $ text (drop 3 ident) where + + ident :: String + ident = show ffiType + +-- | […] +pprInternalBreakpointID :: Module -> InternalBreakpointId -> SDoc +pprInternalBreakpointID currentModule InternalBreakpointId {..} + | ibi_info_mod == currentModule = indexDoc + | otherwise = indexDoc <+> + text "in" <+> + ppr ibi_info_mod + where + + indexDoc :: SDoc + indexDoc = ppr ibi_info_index + +-- | […] +pprPointers :: Module -> FlatBag BCOPtr -> SDoc +pprPointers currentModule = entry (text "pointers:") . + vcatOrNone . + map (pprPointer currentModule) . + elemsFlatBag + +-- | […] +pprPointer :: Module -> BCOPtr -> SDoc +pprPointer currentModule pointer = case pointer of + BCOPtrName name + -> text "name" <+> ppr name + BCOPtrPrimOp primOp + -> text "primitive operation" <+> ppr primOp + BCOPtrBCO byteCodeObject + -> pprByteCodeObject currentModule byteCodeObject + BCOPtrBreakArray breakArrayModule + -> text "break array of module" <+> ppr breakArrayModule + +-- | […] +pprDataConstructorInfoTables :: [(Name, ConInfoTable)] -> SDoc +pprDataConstructorInfoTables = entry (text "data constructor info tables:") . + vcatOrNone . + map (uncurry pprDataConstructorInfoTable) + +-- | […] +pprDataConstructorInfoTable :: Name -> ConInfoTable -> SDoc +pprDataConstructorInfoTable dataConstrName ConInfoTable {..} + = entry (text "info table of" <+> ppr dataConstrName <> text ":") $ + vcat [ + pprTablePositioning $ conItblTablesNextToCode, + pprPointerWordCount $ conItblPtrs, + pprNonPointerWordCount $ conItblNPtrs, + pprConstructorTag $ conItblConTag, + pprPointerTag $ conItblPtrTag, + pprDescription $ conItblDescr + ] + +-- | […] +pprTablePositioning :: Bool -> SDoc +pprTablePositioning = entry (text "tables next to code:") . noOrYes + +-- | […] +pprPointerWordCount :: Int -> SDoc +pprPointerWordCount = entry (text "number of words for pointers:") . ppr + +-- | […] +pprNonPointerWordCount :: Int -> SDoc +pprNonPointerWordCount = entry (text "number of words for non-pointers:") . ppr + +-- | […] +pprConstructorTag :: Int -> SDoc +pprConstructorTag = entry (text "constructor tag:") . ppr + +-- | […] +pprPointerTag :: Int -> SDoc +pprPointerTag = entry (text "pointer tag:") . ppr + +-- | […] +pprDescription :: ByteString -> SDoc +pprDescription = entry (text "description:") . + text . + utf8DecodeByteString + +-- | […] +pprTopLevelStrings :: [(Name, ByteString)] -> SDoc +pprTopLevelStrings = entry (text "top-level strings:") . + vcatOrNone . + map (uncurry pprTopLevelString) + +-- | […] +pprTopLevelString :: Name -> ByteString -> SDoc +pprTopLevelString stringName encodedString + = entry (text "string" <+> ppr stringName <> text ":") $ + text $ + show $ + utf8DecodeByteString $ + encodedString + +-- | […] +pprBreakpoints :: Module -> Maybe InternalModBreaks -> SDoc +pprBreakpoints currentModule + = entry (text "breakpoints:") . + maybe (text "<none>") (pprBreakpointsData currentModule) + +-- | […] +pprBreakpointsData :: Module -> InternalModBreaks -> SDoc +pprBreakpointsData currentModule InternalModBreaks {..} + = vcat [ + pprBreakpointsInSource currentModule $ imodBreaks_modBreaks, + pprBreakpointsInByteCode currentModule $ imodBreaks_breakInfo + ] + +-- | […] +pprBreakpointsInSource :: Module -> ModBreaks -> SDoc +pprBreakpointsInSource currentModule ModBreaks {..} + = entry (text "breakpoints in source:") $ + assert (modBreaks_module == currentModule) $ + assert boundsAreIdentical $ + vcatOrNone $ + pprBreakpointInSource <$> indices modBreaks_locs_ <*> + elems modBreaks_locs_ <*> + elems modBreaks_decls <*> + elems modBreaks_vars <*> + elems modBreaks_ccs + where + + boundsAreIdentical :: Bool + boundsAreIdentical = bounds modBreaks_locs_ == bounds modBreaks_decls && + bounds modBreaks_locs_ == bounds modBreaks_vars && + bounds modBreaks_locs_ == bounds modBreaks_ccs + +-- | […] +pprBreakpointInSource :: BreakTickIndex + -> BinSrcSpan + -> [String] + -> [OccName] + -> (ShortByteString, ShortByteString) + -> SDoc +pprBreakpointInSource ix srcSpan declarationPath freeVars costCenterInfo + = entry (text "breakpoint" <+> ppr ix <> text ":") $ + vcat [ + pprSrcSpan $ srcSpan, + pprDeclarationPath $ declarationPath, + pprFreeVariables $ freeVars, + pprCostCenterPath $ costCenterPath, + pprCostCenterLocation $ costCenterLocation + ] + where + + costCenterPath :: String + costCenterPath = utf8DecodeShortByteString (fst costCenterInfo) + + costCenterLocation :: String + costCenterLocation = utf8DecodeShortByteString (snd costCenterInfo) + + -- The structure of the cost center information is apparent from the + -- implementation of 'GHC.HsToCore.Breakpoints.mkModBreaks'. + +-- | […] +pprSrcSpan :: BinSrcSpan -> SDoc +pprSrcSpan = entry (text "source span:") . ppr . unBinSrcSpan + +-- | […] +pprDeclarationPath :: [String] -> SDoc +pprDeclarationPath = entry (text "declaration path:") . vcat . map text + +-- | […] +pprFreeVariables :: [OccName] -> SDoc +pprFreeVariables = entry (text "free variables:") . hsep . map ppr + +-- | […] +pprCostCenterPath :: String -> SDoc +pprCostCenterPath = entry (text "cost center path:") . text + +-- | […] +pprCostCenterLocation :: String -> SDoc +pprCostCenterLocation = entry (text "cost center location:") . text + +-- | […] +pprBreakpointsInByteCode :: Module -> IntMap CgBreakInfo -> SDoc +pprBreakpointsInByteCode currentModule + = entry (text "breakpoints in bytecode:") . + vcatOrNone . + map (uncurry (pprBreakpointInByteCode currentModule)) . + IntMap.toList + +-- | […] +pprBreakpointInByteCode :: Module -> Int -> CgBreakInfo -> SDoc +pprBreakpointInByteCode currentModule ix CgBreakInfo {..} + = entry (text "breakpoint" <+> ppr ix <> text ":") $ + vcat [ + pprType $ cgb_resty, + pprTypeVariables $ cgb_tyvars, + pprVariables $ cgb_vars, + pprOrigin currentModule $ cgb_tick_id + ] + -- That the 'cgb_resty' field holds the type of the breakpoint is apparent + -- from the fact that this field is set by + -- 'GHC.StgToByteCode.dehydrateCgBreakInfo' using one of its arguments and + -- 'dehydrateCgBreakInfo' is always invoked with this argument set to the + -- extension field of 'Breakpoint', which in turn holds the type of the + -- breakpoint according to Note [Tickish passes] and the comment on the + -- instance declaration of @XBreakpoint 'TickishPassStg@. + +pprType :: IfaceType -> SDoc +pprType = entry (text "type:") . ppr + +-- | […] +pprTypeVariables :: [IfaceTvBndr] -> SDoc +pprTypeVariables = entry (text "type variables:") . + vcat . + map pprTypeVariableBinder + +-- | […] +pprTypeVariableBinder :: IfaceTvBndr -> SDoc +pprTypeVariableBinder (name, kind) = ppr name <+> text "::" <+> ppr kind + +-- | […] +pprVariables :: [Maybe (IfaceIdBndr, Word)] -> SDoc +pprVariables = entry (text "variables:") . + vcat . + map pprVariable + +-- | […] +pprVariable :: Maybe (IfaceIdBndr, Word) -> SDoc +pprVariable = maybe (text "<unknown>") (uncurry pprKnownVariable) + +pprKnownVariable :: IfaceIdBndr -> Word -> SDoc +pprKnownVariable binder offset = pprVariableBinder binder <+> + text "@" <+> + pprFixedSizeNatural offset +-- That the second argument is an offset is apparent from the use of the +-- identifier @offset@ in the implementation of +-- 'GHC.StgToByteCode.dehydrateCgBreakInfo'. + +-- | […] +pprVariableBinder :: IfaceIdBndr -> SDoc +pprVariableBinder (multiplicity, name, type_) + = text "%" <> ppr multiplicity <+> + ppr name <+> text "::" <+> ppr type_ + +pprOrigin :: Module -> Either InternalBreakLoc BreakpointId -> SDoc +pprOrigin currentModule = entry (text "origin:") . + pprBreakpointID currentModule . + either internalBreakLoc id + +-- | […] [analogous to 'pprInternalBreakpointID' but the meaning of the index is different] +pprBreakpointID :: Module -> BreakpointId -> SDoc +pprBreakpointID currentModule BreakpointId {..} + | bi_tick_mod == currentModule = indexDoc + | otherwise = indexDoc <+> text "in" <+> ppr bi_tick_mod + where + + indexDoc :: SDoc + indexDoc = ppr bi_tick_index + +-- | […] +pprStaticPointerTableEntries :: [SptEntry] -> SDoc +pprStaticPointerTableEntries = entry (text "static-pointer table entries:") . + vcatOrNone . + map pprStaticPointerTableEntry + +-- | […] +pprStaticPointerTableEntry :: SptEntry -> SDoc +pprStaticPointerTableEntry (SptEntry name fingerprint) + = ppr fingerprint <> text ":" <+> ppr name + +-- | […] +pprHPCInfo :: Strict.Maybe ByteCodeHpcInfo -> SDoc +pprHPCInfo = entry (text "HPC information:") . + Strict.maybe (text "<none>") pprHPCInfoData + +-- | […] +pprHPCInfoData :: ByteCodeHpcInfo -> SDoc +pprHPCInfoData ByteCodeHpcInfo {..} + = vcat [ + pprHPCInfoHash $ bchi_hash, + pprModuleName $ bchi_module_name, + pprTickBoxName $ bchi_tickbox_name, + pprTickCount $ bchi_tick_count + ] + where + +-- | […] +pprHPCInfoHash :: Int -> SDoc +pprHPCInfoHash = entry (text "hash:") . pprFixedSizeNatural + +-- | […] +pprModuleName :: ShortByteString -> SDoc +pprModuleName = entry (text "module name:") . + text . + utf8DecodeShortByteString + +-- | […] +pprTickBoxName :: ShortByteString -> SDoc +pprTickBoxName = entry (text "tick box name:") . + text . + utf8DecodeShortByteString + +-- | […] +pprTickCount :: Int -> SDoc +pprTickCount = entry (text "number of ticks:") . ppr + +-- | […] +pprObjectFileContents :: [ByteString] -> SDoc +pprObjectFileContents = entry (text "contents of object files:") . + vcatOrNone . + zipWith pprObjectFileContent [0 ..] + +-- | […] +pprObjectFileContent :: Int -> ByteString -> SDoc +pprObjectFileContent ix = entry (text "file" <+> ppr ix <> text ":") . + pprByteString + +-- | […] +pprByteString :: ByteString -> SDoc +pprByteString = pprFixedSizeNaturalList . unpack + +-- | […] +pprBCOByteArray :: (Integral a, FiniteBits a, Storable a, IArray UArray a) => + BCOByteArray a -> SDoc +pprBCOByteArray = pprFixedSizeNaturalList . elems . fromBCOByteArray + +-- | […] +pprFixedSizeNaturalList :: (Integral a, FiniteBits a) => [a] -> SDoc +pprFixedSizeNaturalList [] = text "<empty>" +pprFixedSizeNaturalList list = hsep (map pprFixedSizeNatural list) + +-- | […] +pprFixedSizeNatural :: (Integral a, FiniteBits a) => a -> SDoc +pprFixedSizeNatural num + = text $ replicate (digitCount - length unpadded) '0' ++ unpadded + where + + digitCount :: Int + digitCount = (finiteBitSize num + 3) `div` 4 + + unpadded :: String + unpadded = showHex num "" + +-- | […] +noOrYes :: Bool -> SDoc +noOrYes bool = text (if bool then "yes" else "no") + +-- | […] +entry :: SDoc -> SDoc -> SDoc +entry title content = hang title 2 content + +-- | […] +vcatOrNone :: [SDoc] -> SDoc +vcatOrNone [] = text "<none>" +vcatOrNone docs = vcat docs ===================================== compiler/ghc.cabal.in ===================================== @@ -217,6 +217,7 @@ Library GHC.ByteCode.Linker GHC.ByteCode.Recomp.Binary GHC.ByteCode.Serialize + GHC.ByteCode.Show GHC.ByteCode.Types GHC.Cmm GHC.Cmm.BlockId ===================================== ghc/GHC/Driver/Session/Mode.hs ===================================== @@ -77,6 +77,7 @@ isShowGhciUsageMode _ = False data PostLoadMode = ShowInterface FilePath -- ghc --show-iface + | ShowByteCode FilePath -- ghc --show-byte-code | DoMkDependHS -- ghc -M | StopBefore StopPhase -- ghc -E | -C | -S -- StopBefore StopLn is the default @@ -101,6 +102,9 @@ showUnitsMode = mkPostLoadMode ShowPackages showInterfaceMode :: FilePath -> Mode showInterfaceMode fp = mkPostLoadMode (ShowInterface fp) +showByteCodeMode :: FilePath -> Mode +showByteCodeMode fp = mkPostLoadMode (ShowByteCode fp) + stopBeforeMode :: StopPhase -> Mode stopBeforeMode phase = mkPostLoadMode (StopBefore phase) @@ -231,9 +235,11 @@ mode_flags = replaceSpace ' ' = '-' replaceSpace c = c ] ++ - ------- interfaces ---------------------------------------------------- - [ defFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f) + ------- textual output of generated data ----------------------------- + [ defFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f) "--show-iface")) + , defFlag "-show-byte-code" (HasArg (\f -> setMode (showByteCodeMode f) + "--show-byte-code")) ------- primary modes ------------------------------------------------ , defFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode NoStop) f ===================================== ghc/Main.hs ===================================== @@ -73,6 +73,8 @@ import GHC.SysTools.BaseDir import GHC.Iface.Load import GHC.Iface.Recomp.Binary ( fingerprintBinMem ) +import GHC.ByteCode.Show ( showByteCode ) + import GHC.Tc.Utils.Monad ( initIfaceCheck ) import GHC.Iface.Errors.Ppr @@ -266,6 +268,7 @@ main' postLoadMode units dflags0 args flagWarnings = do (hsc_units hsc_env) (hsc_NC hsc_env) f + ShowByteCode f -> liftIO $ showByteCode logger hsc_env f DoMake -> doMake units srcs DoMkDependHS -> doMkDependHS (map fst srcs) StopBefore p -> liftIO (oneShot hsc_env p srcs) ===================================== libraries/ghci/GHCi/ResolvedBCO.hs ===================================== @@ -7,6 +7,7 @@ module GHCi.ResolvedBCO , isLittleEndian , BCOByteArray(..) , mkBCOByteArray + , fromBCOByteArray ) where #include "MachDeps.h" @@ -20,7 +21,6 @@ import GHCi.BreakArray import Control.Monad import Data.Array.Base (foldrArray, listArray) import Data.ByteString.Builder.Extra -import Foreign.Storable #endif import Data.Binary (Binary(..)) @@ -32,6 +32,7 @@ import GHC.Generics import GHC.Exts import Data.Array.Base (UArray(..)) +import Foreign.Storable import qualified GHC.Exts.Heap as Heap #include "MachDeps.h" @@ -91,13 +92,11 @@ data BCOByteArray a getBCOByteArray :: !ByteArray# } -#if SIZEOF_HSWORD == 4 fromBCOByteArray :: forall a . Storable a => BCOByteArray a -> UArray Int a fromBCOByteArray (BCOByteArray ba#) = UArray 0 (n - 1) n ba# where len# = sizeofByteArray# ba# n = (I# len#) `div` sizeOf (undefined :: a) -#endif mkBCOByteArray :: UArray Int a -> BCOByteArray a mkBCOByteArray (UArray _ _ _ arr) = BCOByteArray arr View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c3a2f8c16f2866c0a567d5c3b05d6e0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c3a2f8c16f2866c0a567d5c3b05d6e0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/multi-caret] Report related locations textually when carets are off
by Simon Jakobi (＠sjakobi2) 09 Jun '26

09 Jun '26

Simon Jakobi pushed to branch wip/sjakobi/multi-caret at Glasgow Haskell Compiler / GHC Commits: 2f8d359f by Simon Jakobi at 2026-06-09T12:48:19+02:00 Report related locations textually when carets are off Related locations were previously visible only as carets. Carets are optional (-fno-diagnostics-show-caret) and some spans have no source to display (GHCi input, TH-generated code, or code remapped by a LINE pragma to a file we can't read), so in those cases the extra locations vanished. decorateDiagnostic now lists, under an "At:" heading printed between the message and the caret snippets, every location that is not shown as a caret -- including the primary span, so the list is a complete set of the locations involved. Each location is shown either as a caret or in the "At:" list. getCaretDiagnostics takes the show-caret flag and returns the real spans that got *no* caret (sorted and deduped), so the list covers exactly the spans the carets missed and the carets-off case is handled in one place; the rendering splits each span into 'Either SDoc RealSrcSpan' via partitionEithers. The Diagnostic GhciMessage instance now forwards diagnosticRelatedLocations, which it previously dropped. Locations are compared and deduped by their real span, which ignores the BufSpan: a duplicate export's related span often differs from the primary only in its BufSpan, which would otherwise be listed twice or mistaken for a location beyond the primary. A list naming only the primary is dropped, since the message header already states it. The now-redundant location prose is removed from TcRnBindingNameConflict ("Bound at:") and TcRnDuplicateDecls ("Declared at:"), and TcRnDuplicateNamedDefaultExport is reworded (its two export items are always identical). TcRnDuplicateExport is left untouched. The single-span getCaretDiagnostic lost its only caller in this rework, so it is dropped along with its exports and .hs-boot declaration. A new test, MultiCaretFallback, exercises a single diagnostic whose related locations are split between carets and the "At:" fallback. Co-Authored-By: Claude Opus 4.8 <noreply(a)anthropic.com> - - - - - 65 changed files: - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Types/Error.hs-boot - compiler/GHC/Utils/Error.hs - compiler/GHC/Utils/Logger.hs - ghc/GHCi/UI/Exception.hs - testsuite/tests/default/T25857.stderr - testsuite/tests/ghci/scripts/T4127a.stderr - testsuite/tests/ghci/scripts/ghci048.stderr - testsuite/tests/haddock/haddock_examples/haddock.Test.stderr - testsuite/tests/indexed-types/should_fail/SimpleFail6.stderr - testsuite/tests/indexed-types/should_fail/T16110_Fail1.stderr - testsuite/tests/mdo/should_fail/mdofail002.stderr - testsuite/tests/mdo/should_fail/mdofail003.stderr - testsuite/tests/module/mod128.stderr - testsuite/tests/module/mod18.stderr - testsuite/tests/module/mod19.stderr - testsuite/tests/module/mod20.stderr - testsuite/tests/module/mod21.stderr - testsuite/tests/module/mod22.stderr - testsuite/tests/module/mod23.stderr - testsuite/tests/module/mod24.stderr - testsuite/tests/module/mod38.stderr - testsuite/tests/module/mod66.stderr - testsuite/tests/overloadedrecflds/should_fail/FieldSelectors.stderr - testsuite/tests/overloadedrecflds/should_fail/NFSDuplicate.stderr - testsuite/tests/overloadedrecflds/should_fail/T17965.stderr - testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail03.stderr - testsuite/tests/patsyn/should_compile/T11959.stderr - testsuite/tests/patsyn/should_compile/T9975a.stderr - testsuite/tests/patsyn/should_fail/T14114.stderr - testsuite/tests/quasiquotation/qq006/qq006.stderr - testsuite/tests/rename/should_compile/ExportWarnings6.stderr - testsuite/tests/rename/should_compile/T23318.stderr - + testsuite/tests/rename/should_fail/MultiCaretFallback.hs - + testsuite/tests/rename/should_fail/MultiCaretFallback.stderr - testsuite/tests/rename/should_fail/T22478b.stderr - testsuite/tests/rename/should_fail/T7164.stderr - testsuite/tests/rename/should_fail/all.T - testsuite/tests/rename/should_fail/rn_dup.stderr - testsuite/tests/rename/should_fail/rnfail001.stderr - testsuite/tests/rename/should_fail/rnfail002.stderr - testsuite/tests/rename/should_fail/rnfail003.stderr - testsuite/tests/rename/should_fail/rnfail004.stderr - testsuite/tests/rename/should_fail/rnfail009.stderr - testsuite/tests/rename/should_fail/rnfail010.stderr - testsuite/tests/rename/should_fail/rnfail011.stderr - testsuite/tests/rename/should_fail/rnfail012.stderr - testsuite/tests/rename/should_fail/rnfail013.stderr - testsuite/tests/rename/should_fail/rnfail015.stderr - testsuite/tests/rename/should_fail/rnfail043.stderr - testsuite/tests/th/T8932.stderr - testsuite/tests/th/TH_dupdecl.stderr - testsuite/tests/th/TH_spliceD1.stderr - testsuite/tests/type-data/should_fail/TDMultiple01.stderr - testsuite/tests/type-data/should_fail/TDMultiple02.stderr - testsuite/tests/type-data/should_fail/TDPunning.stderr - testsuite/tests/typecheck/should_fail/T22560_fail_c.stderr - testsuite/tests/typecheck/should_fail/TyAppPat_NonlinearMultiAppPat.stderr - testsuite/tests/typecheck/should_fail/TyAppPat_NonlinearMultiPat.stderr - testsuite/tests/typecheck/should_fail/TyAppPat_NonlinearSinglePat.stderr - testsuite/tests/typecheck/should_fail/tcfail038.stderr - testsuite/tests/vdq-rta/should_fail/T22326_fail_nonlinear.stderr - testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_3.stderr - testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_4.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2f8d359fd00f968eeac09038910882e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2f8d359fd00f968eeac09038910882e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sort-usages] Switch to 'Usage' sorting by constructor and string IDs
by Wolfgang Jeltsch (＠jeltsch) 09 Jun '26

09 Jun '26

Wolfgang Jeltsch pushed to branch wip/sort-usages at Glasgow Haskell Compiler / GHC Commits: f49f411f by Wolfgang Jeltsch at 2026-06-09T13:50:52+03:00 Switch to 'Usage' sorting by constructor and string IDs - - - - - 3 changed files: - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Unit/Module/Deps.hs - testsuite/tests/driver/recomp016/recomp016.stdout Changes: ===================================== compiler/GHC/HsToCore/Usage.hs ===================================== @@ -12,7 +12,6 @@ import GHC.Tc.Types import GHC.Iface.Load import GHC.Utils.Outputable -import GHC.Utils.Misc import GHC.Utils.Fingerprint import GHC.Utils.Panic import GHC.Utils.Monad @@ -33,7 +32,7 @@ import GHC.Data.Maybe import GHC.Data.FastString import Data.Containers.ListUtils (nubOrdOn) -import Data.List (sortBy, sortOn) +import Data.List (sortBy) import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Set as Set @@ -70,8 +69,8 @@ data UsageConfig = UsageConfig { uc_safe_implicit_imps_req :: !Bool -- ^ Are all implicit imports required to be safe for this Safe Haskell mode? } --- | Build the list of 'Usage's that drives recompilation checking. --- The resulting list is deterministically sorted (see 'usageFingerprint'). +-- | Build the list of 'Usage's that drive recompilation checking. +-- The resulting list is deterministically sorted. mkUsageInfo :: UsageConfig -> Plugins -> FinderCache -> UnitEnv -> Module -> ImportedMods -> [ImportUserSpec] -> NameSet -> [FilePath] -> [FilePath] -> [(Module, Fingerprint)] -> [LinkableUsage] -> PkgsLoaded @@ -102,13 +101,14 @@ mkUsageInfo uc plugins fc unit_env } | (mod, hash) <- merged ] ++ object_usages - - -- Sort all the Usages to ensure a deterministic ordering. - let sorted_usages = sortOn usageFingerprint usages - sorted_usages `seqList` return sorted_usages - -- seq the list of Usages returned: occasionally these - -- don't get evaluated for a while and we can end up hanging on to - -- the entire collection of Ifaces. + return (sortBy stableUsageCmp usages) + -- Note that the sorting serves two purposes: + -- * It makes the order of usages deterministic. + -- * It evaluates the spine of 'usages' and reduces all of its elements to + -- at least WHNF und thus has at least the effect of 'seqList'. + -- The latter is important because occasionally the returned list is not + -- evaluated for a while, so that with too much laziness here we could end + -- up hanging on to the entire collection of 'Iface's. {- Note [Plugin dependencies] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Unit/Module/Deps.hs ===================================== @@ -1,5 +1,8 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE DerivingVia #-} + +{-# OPTIONS_GHC -Wwarn=incomplete-record-selectors #-} + -- | Dependencies and Usage of a module module GHC.Unit.Module.Deps ( Dependencies(dep_direct_mods @@ -17,7 +20,7 @@ module GHC.Unit.Module.Deps , noDependencies , pprDeps , Usage (..) - , usageFingerprint + , stableUsageCmp , HomeModImport (..) , HomeModImportedAvails (..) , ImportAvails (..) @@ -53,6 +56,7 @@ import GHC.Utils.Outputable import Control.DeepSeq import Data.Bifunctor import qualified Data.Foldable as Foldable +import Data.Function (on) import Data.List (sortBy, sort, partition) import Data.Set (Set) import qualified Data.Set as Set @@ -498,16 +502,46 @@ instance Binary Usage where i -> error ("Binary.get(Usage): " ++ show i) --- | Extract the distinguishing fingerprint carried by a particular 'Usage' --- constructor. Every constructor stores a hash capturing the bit of state --- that drives recompilation decisions, so we can sort on it directly. -usageFingerprint :: Usage -> Fingerprint -usageFingerprint UsagePackageModule{ usg_mod_hash = fp } = fp -usageFingerprint UsageHomeModule{ usg_mod_hash = fp } = fp -usageFingerprint UsageFile{ usg_file_hash = fp } = fp -usageFingerprint UsageDirectory{ usg_dir_hash = fp } = fp -usageFingerprint UsageHomeModuleBytecode{ usg_bytecode_hash = fp } = fp -usageFingerprint UsageMergedRequirement{ usg_mod_hash = fp } = fp +-- | Compares 'Usage's by constructor and, if the constructors are the same, by +-- identifying strings, to achieve a predictable ordering. +stableUsageCmp :: Usage -> Usage -> Ordering +stableUsageCmp + usage1@UsagePackageModule {} + usage2@UsagePackageModule {} + = (compare `on` usg_mod) usage1 usage2 +stableUsageCmp + usage1@UsageHomeModule {} + usage2@UsageHomeModule {} + = (compare `on` Module <$> usg_unit_id <*> usg_mod_name) usage1 usage2 +stableUsageCmp + usage1@UsageFile {} + usage2@UsageFile {} + = (lexicalCompareFS `on` usg_file_path) usage1 usage2 +stableUsageCmp + usage1@UsageDirectory {} + usage2@UsageDirectory {} + = (lexicalCompareFS `on` usg_dir_path) usage1 usage2 +stableUsageCmp + usage1@UsageHomeModuleBytecode {} + usage2@UsageHomeModuleBytecode {} + = (compare `on` Module <$> usg_unit_id <*> usg_mod_name) usage1 usage2 +stableUsageCmp + usage1@UsageMergedRequirement {} + usage2@UsageMergedRequirement {} + = (compare `on` usg_mod) usage1 usage2 +stableUsageCmp + usage1 + usage2 + = (compare `on` constructorIndex) usage1 usage2 + where + + constructorIndex :: Usage -> Int + constructorIndex UsagePackageModule {} = 0 + constructorIndex UsageHomeModule {} = 1 + constructorIndex UsageFile {} = 2 + constructorIndex UsageDirectory {} = 3 + constructorIndex UsageHomeModuleBytecode {} = 4 + constructorIndex UsageMergedRequirement {} = 5 -- | Records the imports that we depend on from a home module, -- for recompilation checking. ===================================== testsuite/tests/driver/recomp016/recomp016.stdout ===================================== @@ -9,4 +9,4 @@ second run [2 of 5] Compiling B ( B.hs, B.o ) [Source file changed] [3 of 5] Compiling C ( C.hs, C.o ) [B changed] [4 of 5] Compiling D ( D.hs, D.o ) [C changed] -[5 of 5] Compiling E ( E.hs, E.o ) [D changed] +[5 of 5] Compiling E ( E.hs, E.o ) [B changed] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f49f411f5a429f2a2b725e5a025c9e0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f49f411f5a429f2a2b725e5a025c9e0… 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: testsuite: detect fast bignum via ghc-internal, not removed ghc-bignum
by Marge Bot (＠marge-bot) 09 Jun '26

09 Jun '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 2f3cc9ff by Simon Jakobi at 2026-06-08T07:55:49-04:00 testsuite: detect fast bignum via ghc-internal, not removed ghc-bignum The ghc-bignum package was merged into ghc-internal, so the BIGNUM_GMP probe in test.mk ran `ghc-pkg field ghc-bignum exposed-modules`, which fails with "cannot find package ghc-bignum". That error went to stderr and leaked into the captured stderr of every makefile_test, causing spurious [bad stderr] failures across the suite. The probe also silently returned empty, so config.have_fast_bignum was wrongly False even on GMP builds. Probe ghc-internal's extra-libraries for the gmp library instead: the GMP backend module is an other-module (not exposed), but GMP_LIBS adds gmp to extra-libraries only on a GMP build, so this distinguishes the backends. Redirect stderr to keep any future missing-package error off the harness's stderr. This also removes a stale comment as per suggestion from hsyl20. Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - eb3bf6e7 by Alan Zimmerman at 2026-06-08T07:56:32-04:00 EPA: Rename Transform.anchorEof to addModuleCommentOrigDeltas This now matches what it actually does. - - - - - 0dc97b12 by Brian McKenna at 2026-06-09T06:38:48-04:00 Ignore ticks in the pattern-match term oracle The term-oracle in the pattern-match checker is keyed by a canonical form of the scrutinee, computed by `makeDictsCoherent`. That canonical form was tick-sensitive: two occurrences of an otherwise identical expression that happened to carry different ticks were treated as distinct values, breaking long-distance information. This shows up in practice under `-finfo-table-map`, because the desugarer wraps every record-selector use site in a `SourceNote` carrying that site's span. For example: data Box = Box { unBox :: Maybe Int } f b = case unBox b of Nothing -> 0 Just _ -> let Just x = unBox b in x The two `unBox b` expressionss carry different SourceNote spans, the pattern-match checker sees them as different, the long-distance information from the outer `Just _` branch never reaches the let-pattern, and `Just x = unBox b` is wrongly reported as non-exhaustive. We now strip all ticks in `makeDictsCoherent`. This is documented as Wrinkle (UD1) of Note [Unique dictionaries in the TmOracle CoreMap]. Fixes #27314 - - - - - 3465c065 by David Eichmann at 2026-06-09T06:38:49-04:00 Hadrian: remove unused wrapper scripts from windows bindist These wrapper scripts are only installed on non-relocatable builds which are not generally supported on windows. - - - - - 8 changed files: - + changelog.d/T27314.md - compiler/GHC/HsToCore/Pmc/Solver.hs - hadrian/src/Rules/BinaryDist.hs - testsuite/mk/test.mk - + testsuite/tests/pmcheck/should_compile/T27314.hs - testsuite/tests/pmcheck/should_compile/all.T - utils/check-exact/Main.hs - utils/check-exact/Transform.hs Changes: ===================================== changelog.d/T27314.md ===================================== @@ -0,0 +1,10 @@ +section: compiler +issues: #27314 +mrs: !16118 +synopsis: + Fix spurious ``-Wincomplete-uni-patterns`` warning under ``-finfo-table-map``. +description: + The pattern-match checker now ignores ticks when comparing scrutinees in + its CoreMap, so long-distance information is no longer lost across + function-application scrutinees because debug source annotations + (e.g. SourceNotes added by ``-finfo-table-map``) were inserted. ===================================== compiler/GHC/HsToCore/Pmc/Solver.hs ===================================== @@ -1000,8 +1000,9 @@ makeDictsCoherent (Case scrut bndr ty alts) , let expr' = makeDictsCoherent expr ] makeDictsCoherent (Cast expr co) = Cast (makeDictsCoherent expr) co -makeDictsCoherent (Tick tick expr) - = Tick tick (makeDictsCoherent expr) +makeDictsCoherent (Tick _tick expr) + -- See Wrinkle (UD1) in Note [Unique dictionaries in the TmOracle CoreMap] + = makeDictsCoherent expr makeDictsCoherent ty@(Type {}) = ty makeDictsCoherent co@(Coercion {}) @@ -1061,6 +1062,25 @@ In the end, replacing dictionaries with an error value in the pattern-match checker was the most self-contained, although we might want to revisit once we implement a more robust approach to computing equality in the pattern-match checker (see #19272). + +Wrinkle (UD1): ticks +-------------------- +'makeDictsCoherent' also drops all ticks. The CoreMap key represents +value-level equality, which ticks never affect. + +Example (#27314): with -finfo-table-map every record-selector use site is +wrapped in a 'SourceNote' carrying that site's span (see +Note [Record-selector ticks] in GHC.HsToCore.Ticks). Given + + data Box = Box { unBox :: Maybe Int } + f b = case unBox b of + Nothing -> 0 + Just _ -> let Just x = unBox b in x + +the two `unBox b`s carry different SourceNote spans. Without tick stripping +the CoreMap treats them as distinct expressions. Long-distance information +from the outer `Just _` branch therefore never reaches the let-pattern, and +`Just x = unBox b` is wrongly reported as non-exhaustive. -} {- Note [The Pos/Neg invariant] ===================================== hadrian/src/Rules/BinaryDist.hs ===================================== @@ -290,23 +290,25 @@ bindistRules = do copyFile ("hadrian" -/- "cfg" -/- "default.target.in") (bindistFilesDir -/- "default.target.in") copyFile ("hadrian" -/- "cfg" -/- "default.host.target.in") (bindistFilesDir -/- "default.host.target.in") - -- todo: do we need these wrappers on windows - forM_ bin_targets $ \(pkg, _) -> do - needed_wrappers <- pkgToWrappers pkg - forM_ needed_wrappers $ \wrapper_name -> do - let suffix = if useGhcPrefix pkg - then "ghc-" ++ version - else version - wrapper_content <- wrapper wrapper_name - let unversioned_wrapper_path = bindistFilesDir -/- "wrappers" -/- wrapper_name - versioned_wrapper = wrapper_name ++ "-" ++ suffix - versioned_wrapper_path = bindistFilesDir -/- "wrappers" -/- versioned_wrapper - -- Write the wrapper to the versioned path - writeFile' versioned_wrapper_path wrapper_content - -- Create a symlink from the non-versioned to the versioned. - liftIO $ do - IO.removeFile unversioned_wrapper_path <|> return () - IO.createFileLink versioned_wrapper unversioned_wrapper_path + -- These wrapper scripts are only necessary in the configure/install + -- workflow which is not supported on windows. + unless windowsHost $ do + forM_ bin_targets $ \(pkg, _) -> do + needed_wrappers <- pkgToWrappers pkg + forM_ needed_wrappers $ \wrapper_name -> do + let suffix = if useGhcPrefix pkg + then "ghc-" ++ version + else version + wrapper_content <- wrapper wrapper_name + let unversioned_wrapper_path = bindistFilesDir -/- "wrappers" -/- wrapper_name + versioned_wrapper = wrapper_name ++ "-" ++ suffix + versioned_wrapper_path = bindistFilesDir -/- "wrappers" -/- versioned_wrapper + -- Write the wrapper to the versioned path + writeFile' versioned_wrapper_path wrapper_content + -- Create a symlink from the non-versioned to the versioned. + liftIO $ do + IO.removeFile unversioned_wrapper_path <|> return () + IO.createFileLink versioned_wrapper unversioned_wrapper_path let buildBinDist compressor = do win_target <- isWinTarget ===================================== testsuite/mk/test.mk ===================================== @@ -109,9 +109,11 @@ endif HAVE_GDB := $(shell if gdb --version > /dev/null 2> /dev/null; then echo YES; else echo NO; fi) HAVE_READELF := $(shell if readelf --version > /dev/null 2> /dev/null; then echo YES; else echo NO; fi) -# we need a better way to find which backend is selected and if --check flag is -# used -BIGNUM_GMP := $(shell "$(GHC_PKG)" field ghc-bignum exposed-modules | grep GMP) +# Detect whether the fast (GMP) bignum backend is in use. The GMP backend module +# in ghc-internal is hidden, so we look instead for the gmp library it links +# against: GMP_LIBS adds gmp to ghc-internal's extra-libraries only on a GMP +# build. +BIGNUM_GMP := $(shell "$(GHC_PKG)" field ghc-internal extra-libraries 2>/dev/null | grep gmp) ifeq "$(filter thr, $(GhcRTSWays))" "thr" RUNTEST_OPTS += -e config.ghc_with_threaded_rts=True ===================================== testsuite/tests/pmcheck/should_compile/T27314.hs ===================================== @@ -0,0 +1,8 @@ +module T27314 where + +data Box = Box { unBox :: Maybe Int } + +f :: Box -> Int +f b = case unBox b of + Nothing -> 0 + Just _ -> let Just x = unBox b in x ===================================== testsuite/tests/pmcheck/should_compile/all.T ===================================== @@ -93,6 +93,7 @@ test('T21360', normal, compile, [overlapping_incomplete+'-Wincomplete-record-upd test('T21360b', normal, compile, [overlapping_incomplete+'-Wincomplete-record-updates']) test('T23520', normal, compile, [overlapping_incomplete+'-Wincomplete-record-updates']) test('T25164', [extra_files(['T25164_aux.hs']), req_th], multimod_compile, ['T25164', '-v0']) +test('T27314', normal, compile, ['-Wincomplete-uni-patterns -finfo-table-map']) # Other tests test('pmc001', [], compile, [overlapping_incomplete]) ===================================== utils/check-exact/Main.hs ===================================== @@ -646,7 +646,7 @@ addLocaLDecl3 :: Changer addLocaLDecl3 libdir top = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let - doAddLocal = replaceDecls (anchorEof lp) [parent',d2'] + doAddLocal = replaceDecls (addModuleCommentOrigDeltas lp) [parent',d2'] where lp = top (de1:d2:_) = hsDecls lp @@ -667,7 +667,7 @@ addLocaLDecl4 libdir lp = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") Right newSig <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") let - doAddLocal = replaceDecls (anchorEof lp) (parent':ds) + doAddLocal = replaceDecls (addModuleCommentOrigDeltas lp) (parent':ds) where (parent:ds) = hsDecls (makeDeltaAst lp) @@ -781,7 +781,7 @@ rmDecl3 _libdir lp = do rmDecl4 :: Changer rmDecl4 _libdir lp = do let - doRmDecl = replaceDecls (anchorEof lp) [de1',sd1] + doRmDecl = replaceDecls (addModuleCommentOrigDeltas lp) [de1',sd1] where [de1] = hsDecls lp (de1',Just sd1) = modifyValD (getLocA de1) de1 $ \_m [sd1a,sd2] -> ===================================== utils/check-exact/Transform.hs ===================================== @@ -65,7 +65,7 @@ module Transform , balanceComments , balanceCommentsList , balanceCommentsListA - , anchorEof + , addModuleCommentOrigDeltas -- ** Managing lists, pure functions , captureOrderBinds @@ -724,8 +724,8 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) -- --------------------------------------------------------------------- -anchorEof :: ParsedSource -> ParsedSource -anchorEof (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } }) +addModuleCommentOrigDeltas :: ParsedSource -> ParsedSource +addModuleCommentOrigDeltas (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } }) where an' = addCommentOrigDeltasAnn an View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7da2b3256233f4aeee8beaa1c97e6d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7da2b3256233f4aeee8beaa1c97e6d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/T25450-march-native] Implement -march=native for x86/x86_64
by Simon Jakobi (＠sjakobi2) 09 Jun '26

09 Jun '26

Simon Jakobi pushed to branch wip/sjakobi/T25450-march-native at Glasgow Haskell Compiler / GHC Commits: 12b5f01f by Simon Jakobi at 2026-06-09T11:28:55+02:00 Implement -march=native for x86/x86_64 Add a -march=native flag that probes the host CPU at parse time via an in-process CPUID/XGETBV helper and enables the matching CPU-feature DynFlags, so the effect applies to both the NCG and LLVM backends. The flag handler only records a marker, since flag parsing is pure; the probe and feature application run in parseDynamicFlagsFull, guarded against non-x86 targets and cross-compilation. Detected SSE/AVX and BMI levels are collapsed to their maximum and folded additively into the existing feature flags, so explicit -m... options are never disabled. The probe is memoized for the lifetime of the process. On x86_64 macOS the kernel enables AVX-512 XSAVE state lazily, so XCR0 reads back with the opmask/ZMM bits clear until a process first faults on an AVX-512 instruction. To avoid a false negative there, AVX512F is queried via sysctlbyname(hw.optional.avx512f); the sub-features (BW/CD/DQ/VL) are still decoded from CPUID leaf 7, and AVX/AVX2/FMA stay on the XCR0 path, which is correct on macOS. The flag is registered in expected-undocumented-flags.txt due to #27321. Thanks to @aratamizuki for help with AVX-512 detection on macOS. Closes #25450 Assisted-by: Claude Opus 4.8 <noreply(a)anthropic.com> - - - - - 16 changed files: - + changelog.d/march-native - changelog.d/print-enabled-cpu-features - + compiler/GHC/Driver/CpuFeatures.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Session.hs - + compiler/cbits/cpu_features_x86.c - compiler/ghc.cabal.in - docs/users_guide/expected-undocumented-flags.txt - docs/users_guide/using.rst - testsuite/tests/codeGen/should_gen_asm/all.T - + testsuite/tests/codeGen/should_gen_asm/march-native-enables-popcnt.asm - + testsuite/tests/codeGen/should_gen_asm/march-native-enables-popcnt.hs - testsuite/tests/driver/all.T - + testsuite/tests/driver/march_native.stdout - + testsuite/tests/driver/march_native_additive.stdout - + testsuite/tests/driver/march_native_unsupported_arch.stderr Changes: ===================================== changelog.d/march-native ===================================== @@ -0,0 +1,12 @@ +section: compiler +synopsis: Add -march=native flag +issues: #25450 +mrs: !16126 + +description: + GHC now supports ``-march=native`` on x86 and x86_64. It probes the CPU of the + machine running GHC and enables all of the corresponding ``-m...`` CPU-feature + options automatically (such as ``-msse4.2``, ``-mavx2``, ``-mbmi2`` and + ``-mfma``), for both the native code generator and the LLVM backend. The + detected features are enabled in addition to any explicitly requested feature + flags. The flag is rejected for non-x86 targets and when cross-compiling. ===================================== changelog.d/print-enabled-cpu-features ===================================== @@ -8,9 +8,11 @@ description: prints a JSON object describing the CPU features currently enabled for code generation, together with a set of ``-m...`` flags that reproduce the effective feature set for the current target. - Dynamic options such as ``-mavx2`` and ``-mbmi2`` are respected. :: + Dynamic options such as ``-mavx2`` and ``-mbmi2`` are respected, so the flag + can also be used to inspect which features :ghc-flag:`-march=native` detected + and enabled. :: - $ ghc -mavx2 --print-enabled-cpu-features + $ ghc -march=native --print-enabled-cpu-features {"tag":"enabled-cpu-features","version":1,"target":"x86_64-linux-gnu", - "features":["SSE","SSE2","SSE3","SSSE3","SSE4.1","SSE4.2","AVX","AVX2"], - "as_m_flags":["-mavx2"]} + "features":["SSE","SSE2","SSE3","SSSE3","SSE4.1","SSE4.2","AVX","AVX2","BMI1","BMI2","FMA"], + "as_m_flags":["-mavx2","-mbmi2","-mfma"]} ===================================== compiler/GHC/Driver/CpuFeatures.hs ===================================== @@ -0,0 +1,87 @@ +{-# LANGUAGE CPP #-} + +module GHC.Driver.CpuFeatures + ( X86CpuFeature(..) + , cachedX86CpuFeatures + ) where + +import GHC.Prelude + +import Data.Word (Word64) +import System.IO.Unsafe (unsafePerformIO) + +-- | x86 CPU features understood by GHC's native CPU feature probe. +data X86CpuFeature + = SSE2 + | SSE3 + | SSSE3 + | SSE4_1 + | SSE4_2 + | AVX + | AVX2 + | AVX512F + | AVX512BW + | AVX512CD + | AVX512DQ + | AVX512VL + | BMI1 + | BMI2 + | FMA + | GFNI + deriving (Eq, Ord, Show) + +-- | Decode the bitmask returned by 'ghc_detect_x86_cpu_features'. +-- +-- NOTE: Bit positions must match the enum in @compiler/cbits/cpu_features_x86.c@. +decodeX86CpuFeatureMask :: Word64 -> [X86CpuFeature] +decodeX86CpuFeatureMask mask = + [ feat + | (bit_ix, feat) <- cpuFeatureBitLayout + , testBit mask bit_ix + ] + +-- | Low-level FFI access to the C probe. +detectX86CpuFeatureMask :: IO Word64 +#if defined(javascript_HOST_ARCH) +detectX86CpuFeatureMask = pure 0 +#else +detectX86CpuFeatureMask = c_ghc_detect_x86_cpu_features +#endif + +-- | Probe host x86 CPU features and decode them into an ordered feature list. +detectX86CpuFeatures :: IO [X86CpuFeature] +detectX86CpuFeatures = decodeX86CpuFeatureMask <$> detectX86CpuFeatureMask + +-- | The host's x86 CPU features, probed once and memoized. +-- +-- CPUID results are constant for the lifetime of the process, so probing more +-- than once (e.g. once per @-march=native@ in a command line or file pragma) +-- is wasteful. This is referentially transparent despite the FFI call. +cachedX86CpuFeatures :: [X86CpuFeature] +cachedX86CpuFeatures = unsafePerformIO detectX86CpuFeatures +{-# NOINLINE cachedX86CpuFeatures #-} + +cpuFeatureBitLayout :: [(Int, X86CpuFeature)] +cpuFeatureBitLayout = + [ (0, SSE2) + , (1, SSE3) + , (2, SSSE3) + , (3, SSE4_1) + , (4, SSE4_2) + , (5, AVX) + , (6, AVX2) + , (7, AVX512F) + , (8, AVX512BW) + , (9, AVX512CD) + , (10, AVX512DQ) + , (11, AVX512VL) + , (12, BMI1) + , (13, BMI2) + , (14, FMA) + , (15, GFNI) + ] + +#if !defined(javascript_HOST_ARCH) +foreign import ccall unsafe "ghc_detect_x86_cpu_features" + c_ghc_detect_x86_cpu_features :: IO Word64 +#endif ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -470,6 +470,8 @@ data DynFlags = DynFlags { fma :: Bool, -- ^ Enable FMA instructions. gfni :: Bool, -- ^ Enable GFNI Instructions. la664 :: Bool, -- ^ Enable LA664 instructions + marchNative :: Bool, -- ^ @-march=native@ was requested; the host + -- CPU features are applied during flag parsing. -- Constants used to control the amount of optimization done. @@ -760,6 +762,7 @@ defaultDynFlags mySettings = gfni = False, -- For LoongArch, la464 is used by default. la664 = False, + marchNative = False, maxInlineAllocSize = 128, maxInlineMemcpyInsns = 32, ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -245,6 +245,8 @@ import GHC.Platform import GHC.Platform.Ways import GHC.Platform.Profile import GHC.Platform.ArchOS +import GHC.Platform.Host (hostPlatformArch) +import qualified GHC.Driver.CpuFeatures as Cpu import GHC.Unit.Types import GHC.Unit.Parser @@ -906,8 +908,12 @@ parseDynamicFlagsFull activeFlags cmdline logger dflags0 args = do unless (null errs) $ liftIO $ throwGhcExceptionIO $ errorsToGhcException $ map ((rdr . ppr . getLoc &&& unLoc) . errMsg) $ errs + -- Apply -march=native: probe the host CPU and enable the matching feature + -- flags. This needs IO (CPUID), so it cannot live in the pure flag handlers. + dflags1' <- applyMarchNative dflags1 + -- check for disabled flags in safe haskell - let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1 + let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1' theWays = ways dflags2 unless (allowed_combination theWays) $ liftIO $ @@ -1743,6 +1749,7 @@ dynamic_flags_deps = [ , make_ord_flag defGhcFlag "mavx512vl" (noArg (\d -> d { avx512vl = True })) , make_ord_flag defGhcFlag "mfma" (noArg (\d -> d { fma = True })) , make_ord_flag defGhcFlag "mgfni" (noArg (\d -> d { gfni = True })) + , make_ord_flag defGhcFlag "march=native" (noArg (\d -> d { marchNative = True })) , make_ord_flag defGhcFlag "mla664" (noArg (\d -> d { la664 = True })) @@ -3806,6 +3813,59 @@ x86AsMFlags dflags = gfniFlags = [ "-mgfni" | gfni dflags ] +-- | Apply a requested @-march=native@ by probing the host CPU and enabling the +-- matching CPU-feature flags. +-- +-- This runs in 'parseDynamicFlagsFull' rather than in a flag handler because the +-- CPUID probe needs 'IO', whereas flag handlers are pure. The detected features +-- are folded into the existing feature 'DynFlags' so that 'makeDynFlagsConsistent' +-- and the backends treat them exactly like the corresponding @-m...@ flags. +applyMarchNative :: MonadIO m => DynFlags -> m DynFlags +applyMarchNative dflags + | not (marchNative dflags) = return dflags + | otherwise = do + let arch = platformArch (targetPlatform dflags) + unless (arch == ArchX86 || arch == ArchX86_64) $ liftIO $ + throwGhcExceptionIO $ CmdLineError + "-march=native is only supported on x86 and x86_64 targets" + unless (arch == hostPlatformArch) $ liftIO $ + throwGhcExceptionIO $ CmdLineError + "-march=native is not supported when cross-compiling" + return (applyX86CpuFeatures Cpu.cachedX86CpuFeatures dflags) + +-- | Enable the 'DynFlags' CPU-feature fields corresponding to a probed set of +-- host x86 features. SSE/AVX and BMI levels are collapsed to their maximum, +-- since 'sseAvxVersion' and 'bmiVersion' each record a single level. +applyX86CpuFeatures :: [Cpu.X86CpuFeature] -> DynFlags -> DynFlags +applyX86CpuFeatures feats dflags = dflags + { sseAvxVersion = foldr (max . Just) (sseAvxVersion dflags) sseLevels + , bmiVersion = foldr (max . Just) (bmiVersion dflags) bmiLevels + , avx512f = avx512f dflags || has Cpu.AVX512F + , avx512bw = avx512bw dflags || has Cpu.AVX512BW + , avx512cd = avx512cd dflags || has Cpu.AVX512CD + , avx512dq = avx512dq dflags || has Cpu.AVX512DQ + , avx512vl = avx512vl dflags || has Cpu.AVX512VL + , fma = fma dflags || has Cpu.FMA + , gfni = gfni dflags || has Cpu.GFNI + } + where + has feat = feat `elem` feats + sseLevels = [ lvl | feat <- feats, Just lvl <- [sseLevelOf feat] ] + bmiLevels = [ lvl | feat <- feats, Just lvl <- [bmiLevelOf feat] ] + sseLevelOf feat = case feat of + Cpu.SSE2 -> Just SSE2 + Cpu.SSE3 -> Just SSE3 + Cpu.SSSE3 -> Just SSSE3 + Cpu.SSE4_1 -> Just SSE4 + Cpu.SSE4_2 -> Just SSE42 + Cpu.AVX -> Just AVX1 + Cpu.AVX2 -> Just AVX2 + _ -> Nothing + bmiLevelOf feat = case feat of + Cpu.BMI1 -> Just BMI1 + Cpu.BMI2 -> Just BMI2 + _ -> Nothing + -- | Query if the target RTS has the given 'Ways'. It's computed from -- the @"RTS ways"@ field in the settings file. targetHasRTSWays :: DynFlags -> Ways -> Bool ===================================== compiler/cbits/cpu_features_x86.c ===================================== @@ -0,0 +1,208 @@ +#include <HsFFI.h> +#include <stdint.h> + +#if defined(_MSC_VER) && (defined(_M_IX86) || defined(_M_X64)) +#include <immintrin.h> +#include <intrin.h> +#endif + +#if !defined(_MSC_VER) && (defined(__i386__) || defined(__x86_64__)) +#include <cpuid.h> +#endif + +#if defined(__APPLE__) && (defined(__i386__) || defined(__x86_64__)) +#include <sys/sysctl.h> +#endif + +enum { + GHC_X86_FEAT_SSE2 = 0, + GHC_X86_FEAT_SSE3, + GHC_X86_FEAT_SSSE3, + GHC_X86_FEAT_SSE4_1, + GHC_X86_FEAT_SSE4_2, + GHC_X86_FEAT_AVX, + GHC_X86_FEAT_AVX2, + GHC_X86_FEAT_AVX512F, + GHC_X86_FEAT_AVX512BW, + GHC_X86_FEAT_AVX512CD, + GHC_X86_FEAT_AVX512DQ, + GHC_X86_FEAT_AVX512VL, + GHC_X86_FEAT_BMI1, + GHC_X86_FEAT_BMI2, + GHC_X86_FEAT_FMA, + GHC_X86_FEAT_GFNI +}; + +#define SET_FEAT(mask, bit) ((mask) |= ((HsWord64)1ULL << (bit))) + +static int ghc_cpuid_count(uint32_t leaf, uint32_t subleaf, + uint32_t *a, uint32_t *b, uint32_t *c, uint32_t *d) +{ +#if defined(_MSC_VER) && (defined(_M_IX86) || defined(_M_X64)) + int regs[4]; + __cpuidex(regs, (int)leaf, (int)subleaf); + *a = (uint32_t)regs[0]; + *b = (uint32_t)regs[1]; + *c = (uint32_t)regs[2]; + *d = (uint32_t)regs[3]; + return 1; +#elif defined(__i386__) || defined(__x86_64__) + return __get_cpuid_count(leaf, subleaf, a, b, c, d); +#else + (void)leaf; + (void)subleaf; + (void)a; + (void)b; + (void)c; + (void)d; + return 0; +#endif +} + +static uint64_t ghc_xgetbv0(void) +{ +#if defined(_MSC_VER) && (defined(_M_IX86) || defined(_M_X64)) + return (uint64_t)_xgetbv(0); +#elif defined(__i386__) || defined(__x86_64__) + uint32_t eax, edx; + __asm__ volatile(".byte 0x0f, 0x01, 0xd0" /* xgetbv */ + : "=a"(eax), "=d"(edx) + : "c"(0)); + return ((uint64_t)edx << 32) | (uint64_t)eax; +#else + return 0; +#endif +} + +#if defined(__APPLE__) && (defined(__i386__) || defined(__x86_64__)) +/* Query a macOS CPU-capability sysctl, e.g. "hw.optional.avx512f". */ +static int ghc_macos_sysctl_flag(const char *name) +{ + int result = 0; + size_t len = sizeof(result); + if (sysctlbyname(name, &result, &len, NULL, 0) != 0) { + return 0; + } + return result != 0; +} +#endif + +HsWord64 ghc_detect_x86_cpu_features(void) +{ + HsWord64 feats = 0; + +#if defined(_M_IX86) || defined(_M_X64) || defined(__i386__) || defined(__x86_64__) + uint32_t a, b, c, d; + uint32_t max_basic = 0; + + if (!ghc_cpuid_count(0, 0, &a, &b, &c, &d)) { + return 0; + } + max_basic = a; + if (max_basic < 1) { + return 0; + } + + ghc_cpuid_count(1, 0, &a, &b, &c, &d); + + { + int has_sse2 = !!(d & (1u << 26)); + int has_sse3 = !!(c & (1u << 0)); + int has_ssse3 = !!(c & (1u << 9)); + int has_sse4_1 = !!(c & (1u << 19)); + int has_sse4_2 = !!(c & (1u << 20)); + int has_fma_hw = !!(c & (1u << 12)); + int has_avx_hw = !!(c & (1u << 28)); + int has_osxsave = !!(c & (1u << 27)); + + int avx_usable = 0; + int avx512_usable = 0; + + if (has_osxsave) { + uint64_t xcr0 = ghc_xgetbv0(); + avx_usable = ((xcr0 & 0x6u) == 0x6u); /* XMM + YMM state */ + avx512_usable = ((xcr0 & 0xE6u) == 0xE6u); /* XMM+YMM+opmask+ZMM */ + } + +#if defined(__APPLE__) + /* On x86_64 macOS the kernel enables AVX-512 XSAVE state lazily: XCR0 + reads back with the opmask/ZMM bits clear until a process first faults + on an AVX-512 instruction, so the XCR0 check above is a false negative + on AVX-512-capable Macs. Use the OS feature query instead. Checking + AVX512F alone suffices here; the AVX-512 sub-features (BW/CD/DQ/VL) are + still decoded from CPUID leaf 7 below. + + Refs: + https://zenn.dev/mod_poppo/articles/detect-processor-features-x86?locale=en… + https://github.com/minoki/haskell-cpu-features */ + avx512_usable = ghc_macos_sysctl_flag("hw.optional.avx512f"); +#endif + + if (has_sse2) { + SET_FEAT(feats, GHC_X86_FEAT_SSE2); + } + if (has_sse3) { + SET_FEAT(feats, GHC_X86_FEAT_SSE3); + } + if (has_ssse3) { + SET_FEAT(feats, GHC_X86_FEAT_SSSE3); + } + if (has_sse4_1) { + SET_FEAT(feats, GHC_X86_FEAT_SSE4_1); + } + if (has_sse4_2) { + SET_FEAT(feats, GHC_X86_FEAT_SSE4_2); + } + if (has_avx_hw && avx_usable) { + SET_FEAT(feats, GHC_X86_FEAT_AVX); + } + if (has_fma_hw && avx_usable) { + SET_FEAT(feats, GHC_X86_FEAT_FMA); + } + + if (max_basic >= 7 && ghc_cpuid_count(7, 0, &a, &b, &c, &d)) { + int has_bmi1 = !!(b & (1u << 3)); + int has_avx2_hw = !!(b & (1u << 5)); + int has_bmi2 = !!(b & (1u << 8)); + int has_avx512f = !!(b & (1u << 16)); + int has_avx512dq = !!(b & (1u << 17)); + int has_avx512cd = !!(b & (1u << 28)); + int has_avx512bw = !!(b & (1u << 30)); + int has_avx512vl = !!(b & (1u << 31)); + int has_gfni = !!(c & (1u << 8)); + + if (has_bmi1) { + SET_FEAT(feats, GHC_X86_FEAT_BMI1); + } + if (has_bmi2) { + SET_FEAT(feats, GHC_X86_FEAT_BMI2); + } + if (avx_usable && has_avx2_hw) { + SET_FEAT(feats, GHC_X86_FEAT_AVX2); + } + + if (avx512_usable && has_avx512f) { + SET_FEAT(feats, GHC_X86_FEAT_AVX512F); + if (has_avx512bw) { + SET_FEAT(feats, GHC_X86_FEAT_AVX512BW); + } + if (has_avx512cd) { + SET_FEAT(feats, GHC_X86_FEAT_AVX512CD); + } + if (has_avx512dq) { + SET_FEAT(feats, GHC_X86_FEAT_AVX512DQ); + } + if (has_avx512vl) { + SET_FEAT(feats, GHC_X86_FEAT_AVX512VL); + } + } + + if (has_gfni) { + SET_FEAT(feats, GHC_X86_FEAT_GFNI); + } + } + } +#endif + + return feats; +} ===================================== compiler/ghc.cabal.in ===================================== @@ -187,6 +187,7 @@ Library else c-sources: cbits/cutils.c + cbits/cpu_features_x86.c cbits/genSym.c cbits/keepCAFsForGHCi.c @@ -514,6 +515,7 @@ Library GHC.Driver.Config.StgToCmm GHC.Driver.Config.Tidy GHC.Driver.Config.StgToJS + GHC.Driver.CpuFeatures GHC.Driver.DynFlags GHC.Driver.IncludeSpecs GHC.Driver.Downsweep ===================================== docs/users_guide/expected-undocumented-flags.txt ===================================== @@ -75,6 +75,7 @@ -instantiated-with -keep-hi-file -keep-o-file +-march=native -n -no-keep-hi-file -no-keep-o-file ===================================== docs/users_guide/using.rst ===================================== @@ -496,7 +496,9 @@ The available mode flags are: Print a JSON object describing the CPU features currently enabled for code generation, together with a set of ``-m...`` flags that reproduce the effective feature set for the current target. - Dynamic options such as ``-mavx2`` and ``-mbmi2`` are respected. + Dynamic options such as ``-mavx2`` and ``-mbmi2`` are respected, so this flag + can also be used to inspect which features :ghc-flag:`-march=native` detected + and enabled. .. ghc-flag:: --print-debug-on :shortdesc: print whether GHC was built with ``-DDEBUG`` @@ -1854,6 +1856,34 @@ Some flags only make sense for particular target platforms. so this flag has no effect when used with the :ref:`native code generator <native-code-gen>` or the :ref:`LLVM backend <llvm-code-gen>`. +.. ghc-flag:: -march=native + :shortdesc: (x86 only) Enable all CPU features supported by the host + :type: dynamic + :category: platform-options + + (x86/x86_64 only) Probe the CPU of the machine running GHC and enable all of + the corresponding ``-m...`` CPU-feature options automatically (for example + ``-msse4.2``, ``-mavx2``, ``-mbmi2``, ``-mfma``). The detected features apply + to both the :ref:`native code generator <native-code-gen>` and the + :ref:`LLVM backend <llvm-code-gen>`. + + The detected features are enabled *in addition* to any CPU-feature flags you + pass explicitly, regardless of their order on the command line; ``-march=native`` + never disables a feature. + + The features that were detected and enabled can be inspected with + :ghc-flag:`--print-enabled-cpu-features`. + + .. warning:: + + Code compiled with ``-march=native`` may use instructions that are not + available on other CPUs, and is therefore not portable to a different + machine. + + Only x86 and x86_64 targets are supported so far; the flag is rejected on + other targets. It is also rejected when cross-compiling, since the host CPU + is then unrelated to the target. + Haddock ------- ===================================== testsuite/tests/codeGen/should_gen_asm/all.T ===================================== @@ -17,6 +17,11 @@ test('msse-option-order', [unless(arch('x86_64') or arch('i386'), skip), when(unregisterised(), skip)], compile_grep_asm, ['hs', False, '-msse4.2 -msse2']) test('mavx-should-enable-popcnt', [unless(arch('x86_64') or arch('i386'), skip), when(unregisterised(), skip)], compile_grep_asm, ['hs', False, '-mavx']) +# -march=native probes the host CPU, so gate on the host actually having SSE4.2 +# (have_cpu_feature reports nothing under cross, skipping the test there too). +test('march-native-enables-popcnt', + [unless((arch('x86_64') or arch('i386')) and have_cpu_feature('sse4_2'), skip), + when(unregisterised(), skip)], compile_grep_asm, ['hs', False, '-march=native']) test('avx512-int64-mul', [unless(arch('x86_64'), skip), when(unregisterised(), skip)], compile_grep_asm, ['hs', True, '-mavx512dq -mavx512vl']) test('avx512-int64-minmax', [unless(arch('x86_64'), skip), ===================================== testsuite/tests/codeGen/should_gen_asm/march-native-enables-popcnt.asm ===================================== @@ -0,0 +1 @@ +popcnt(?![0-9]) \ No newline at end of file ===================================== testsuite/tests/codeGen/should_gen_asm/march-native-enables-popcnt.hs ===================================== @@ -0,0 +1,11 @@ +-- `-march=native` enables the host's CPU features. On a host with SSE4.2 +-- (gated in all.T via have_cpu_feature) this makes popCount compile to a +-- `popcnt` instruction rather than the SSE2-baseline software fallback. +import Data.Bits + +{-# NOINLINE foo #-} +foo :: Int -> Int +foo x = 1 + popCount x + +main :: IO () +main = print (foo 42) ===================================== testsuite/tests/driver/all.T ===================================== @@ -7,6 +7,12 @@ def normalise_unknown_flag(msg): m = re.search(r'unrecognised flag: \S+', msg) return m.group(0) + '\n' if m else msg +def normalise_march_native_error(msg): + # Keep only the stable '-march=native ...' diagnostic; the program-name + # prefix and any usage trailer vary across configurations. + m = re.search(r'-march=native is [^\n]+', msg) + return m.group(0) + '\n' if m else msg + test('driver011', [extra_files(['A011.hs'])], makefile_test, ['test011']) test('driver012', [extra_files(['A012.hs'])], makefile_test, ['test012']) @@ -265,6 +271,45 @@ test('print_enabled_cpu_features_unknown_flag', run_command, ['{compiler} -mavx22 --print-enabled-cpu-features']) +# -march=native enables at least the x86_64 baseline (SSE2). The full feature +# set is host-dependent, so we only assert the always-present baseline. +test('march_native', + [unless(arch('x86_64') or arch('i386'), skip)], + run_command, + ['{compiler} -march=native --print-enabled-cpu-features | grep -o SSE2']) + +# On non-x86 targets -march=native must be rejected. +test('march_native_unsupported_arch', + [when(arch('x86_64') or arch('i386'), skip), + normalise_errmsg_fun(normalise_march_native_error), exit_code(1)], + run_command, + ['{compiler} -march=native --print-enabled-cpu-features']) + +# -march=native is additive: its feature set is a superset of the default set. +# We extract the "features" arrays with and without the flag and assert that no +# baseline feature is dropped: 'grep -vxF -f native.txt base.txt' prints any +# baseline feature absent from the -march=native set, of which we expect none. +# (grep exits 1 when it prints nothing, so '|| true' keeps the success case from +# failing the test; the empty-stdout check is what enforces the assertion.) +# This avoids hard-coding the host-specific feature set. +test('march_native_superset', + [unless(arch('x86_64') or arch('i386'), skip)], + run_command, + ['{compiler} --print-enabled-cpu-features | ' + 'sed \'s/.*"features":\\[//;s/].*//;s/"//g\' | tr \',\' \'\\n\' > base.txt && ' + '{compiler} -march=native --print-enabled-cpu-features | ' + 'sed \'s/.*"features":\\[//;s/].*//;s/"//g\' | tr \',\' \'\\n\' > native.txt && ' + '(grep -vxF -f native.txt base.txt || true)']) + +# -march=native is additive with explicit -m flags, regardless of order: an +# explicitly requested feature (here AVX2, forced on independent of the host) is +# still present whether the flag comes before or after -march=native. +test('march_native_additive', + [unless(arch('x86_64') or arch('i386'), skip)], + run_command, + ['{compiler} -mavx2 -march=native --print-enabled-cpu-features | grep -o AVX2 && ' + '{compiler} -march=native -mavx2 --print-enabled-cpu-features | grep -o AVX2']) + test('T10219', normal, run_command, # `-x hspp` in make mode should work. # Note: need to specify `-x hspp` before the filename. ===================================== testsuite/tests/driver/march_native.stdout ===================================== @@ -0,0 +1 @@ +SSE2 ===================================== testsuite/tests/driver/march_native_additive.stdout ===================================== @@ -0,0 +1,2 @@ +AVX2 +AVX2 ===================================== testsuite/tests/driver/march_native_unsupported_arch.stderr ===================================== @@ -0,0 +1 @@ +-march=native is only supported on x86 and x86_64 targets View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12b5f01f8e7b3aebe2393c60fd09ec4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12b5f01f8e7b3aebe2393c60fd09ec4… You're receiving this email because of your account on gitlab.haskell.org.

1 0