diff options
| author | Simon Jakobi <simon.jakobi@gmail.com> | 2019-06-04 02:54:35 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2019-06-07 10:25:16 -0400 |
| commit | be63d2996308c77f8a0a44592074c98f66a80e93 (patch) | |
| tree | a909f8ac110302edb84e70c4c7b2073209588037 | |
| parent | 9bb58799d2ce58f6aef772df79ad26210403aded (diff) | |
| download | haskell-be63d2996308c77f8a0a44592074c98f66a80e93.tar.gz | |
Fix isValidNatural: The BigNat in NatJ# must have at least 2 limbs
Previously the `integer-gmp` variant of `isValidNatural` would fail to
detect values `<= maxBound::Word` that were incorrectly encoded using
the `NatJ#` constructor.
| -rw-r--r-- | libraries/base/GHC/Natural.hs | 4 | ||||
| -rw-r--r-- | libraries/base/changelog.md | 4 | ||||
| -rw-r--r-- | libraries/base/tests/all.T | 1 | ||||
| -rw-r--r-- | libraries/base/tests/isValidNatural.hs | 9 | ||||
| -rw-r--r-- | libraries/base/tests/isValidNatural.stdout | 1 | ||||
| -rw-r--r-- | libraries/integer-gmp/src/GHC/Integer/Type.hs | 2 |
6 files changed, 20 insertions, 1 deletions
diff --git a/libraries/base/GHC/Natural.hs b/libraries/base/GHC/Natural.hs index b452d5119d..93c67b6c7a 100644 --- a/libraries/base/GHC/Natural.hs +++ b/libraries/base/GHC/Natural.hs @@ -157,7 +157,9 @@ data Natural = NatS# GmpLimb# -- ^ in @[0, maxBound::Word]@ isValidNatural :: Natural -> Bool isValidNatural (NatS# _) = True isValidNatural (NatJ# bn) = isTrue# (isValidBigNat# bn) - && isTrue# (sizeofBigNat# bn ># 0#) + -- A 1-limb BigNat could fit into a NatS#, so we + -- require at least 2 limbs. + && isTrue# (sizeofBigNat# bn ># 1#) signumNatural :: Natural -> Natural signumNatural (NatS# 0##) = NatS# 0## diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index 6da0c70b36..a9f6fcf272 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -5,6 +5,10 @@ * Add a `TestEquality` instance for the `Compose` newtype. + * Fix the `integer-gmp` variant of `isValidNatural`: Previously it would fail + to detect values `<= maxBound::Word` that were incorrectly encoded using + the `NatJ#` constructor. + ## 4.13.0.0 *TBA* * Bundled with GHC *TBA* diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T index 86c3ec9477..97d3ca4168 100644 --- a/libraries/base/tests/all.T +++ b/libraries/base/tests/all.T @@ -40,6 +40,7 @@ test('take001', extra_run_opts('1'), compile_and_run, ['']) test('inits', normal, compile_and_run, ['']) test('genericNegative001', extra_run_opts('-1'), compile_and_run, ['']) test('ix001', normal, compile_and_run, ['']) +test('isValidNatural', reqlib('integer-gmp'), compile_and_run, ['']) # need to add -K64m to the compiler opts, so that GHCi gets it too test('ioref001', diff --git a/libraries/base/tests/isValidNatural.hs b/libraries/base/tests/isValidNatural.hs new file mode 100644 index 0000000000..1b062f0309 --- /dev/null +++ b/libraries/base/tests/isValidNatural.hs @@ -0,0 +1,9 @@ +{-# language MagicHash #-} + +import GHC.Integer.GMP.Internals +import GHC.Natural + +main = print $ map isValidNatural [0, 1, maxWord, maxWord + 1, invalid] + where + maxWord = fromIntegral (maxBound :: Word) + invalid = NatJ# oneBigNat -- 1 would fit into the NatS# constructor. diff --git a/libraries/base/tests/isValidNatural.stdout b/libraries/base/tests/isValidNatural.stdout new file mode 100644 index 0000000000..ccb5c6c2d0 --- /dev/null +++ b/libraries/base/tests/isValidNatural.stdout @@ -0,0 +1 @@ +[True,True,True,True,False] diff --git a/libraries/integer-gmp/src/GHC/Integer/Type.hs b/libraries/integer-gmp/src/GHC/Integer/Type.hs index 521cd95a25..14bdb57ffd 100644 --- a/libraries/integer-gmp/src/GHC/Integer/Type.hs +++ b/libraries/integer-gmp/src/GHC/Integer/Type.hs @@ -1778,6 +1778,8 @@ foreign import ccall unsafe "gmp.h __gmpn_popcount" -- BigNat-wrapped ByteArray#-primops -- | Return number of limbs contained in 'BigNat'. +-- +-- The result is always @>= 1@ since even zero is encoded with 1 limb. sizeofBigNat# :: BigNat -> GmpSize# sizeofBigNat# (BN# x#) = sizeofByteArray# x# `uncheckedIShiftRL#` GMP_LIMB_SHIFT# |