Fix the right-shift operation for negative big integers (fixes #12136)

In `x shiftR y`, any of the following conditions cause an abort:
- `x` is a negative big integer
- The size of `x` and `y` is a multiple of `GMP_NUMB_BITS`
- The bit of the absolute value of `x` is filled with `1`

For example:
Assuming `GMP_NUMB_BITS = 2`,  the processing of `-15 shiftR 2` is as 
follows:

1. -15 = -1111 (twos complement: 10001)
2. right shift 2 (as a positive number) -> 0011
3. Due to the shift larger than GMP_NUMB_BITS, the size of the 
destination is decreasing (2bit) -> 11
4. Add 1, and get carry: (1) 00
5. abort

I fixed it that the destination size does not decrease in such a case.

Test Plan: I tested the specific case being reported.

Reviewers: goldfire, austin, hvr, bgamari, rwbarton

Reviewed By: bgamari, rwbarton

Subscribers: mpickering, rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D2998

GHC Trac Issues: #12136

5 files changed, 33 insertions, 4 deletions

diff --git a/libraries/integer-gmp/cbits/wrappers.c b/libraries/integer-gmp/cbits/wrappers.c
index 1736efdc5c..c99c0176a4 100644
--- a/libraries/integer-gmp/cbits/wrappers.c
+++ b/libraries/integer-gmp/cbits/wrappers.c
@@ -105,7 +105,10 @@ integer_gmp_mpn_rshift (mp_limb_t rp[], const mp_limb_t sp[], mp_size_t sn,
 /* Twos-complement version of 'integer_gmp_mpn_rshift' for performing
  * arithmetic right shifts on "negative" MPNs.
  *
- * Same pre-conditions as 'integer_gmp_mpn_rshift'
+ * pre-conditions:
+ *  - 0 < count < sn*GMP_NUMB_BITS
+ *  - rn = sn - floor((count - 1) / GMP_NUMB_BITS)
+ *  - sn > 0
  *
  * This variant is needed to operate on MPNs interpreted as negative
  * numbers, which require "rounding" towards minus infinity iff a
@@ -117,7 +120,7 @@ integer_gmp_mpn_rshift_2c (mp_limb_t rp[], const mp_limb_t sp[],
 {
   const mp_size_t    limb_shift = count / GMP_NUMB_BITS;
   const unsigned int bit_shift  = count % GMP_NUMB_BITS;
-  const mp_size_t    rn         = sn - limb_shift;
+  mp_size_t    rn         = sn - limb_shift;
 
   // whether non-zero bits were shifted out
   bool nz_shift_out = false;
@@ -125,8 +128,13 @@ integer_gmp_mpn_rshift_2c (mp_limb_t rp[], const mp_limb_t sp[],
   if (bit_shift) {
     if (mpn_rshift(rp, &sp[limb_shift], rn, bit_shift))
       nz_shift_out = true;
-  } else
+  } else {
+    // rp was allocated (rn + 1) limbs, to prevent carry
+    // on mpn_add_1 when all the bits of {rp, rn} are 1.
+    memset(&rp[rn], 0, sizeof(mp_limb_t));
     memcpy(rp, &sp[limb_shift], rn*sizeof(mp_limb_t));
+    rn++;
+  }
 
   if (!nz_shift_out)
     for (unsigned i = 0; i < limb_shift; i++)
diff --git a/libraries/integer-gmp/src/GHC/Integer/Type.hs b/libraries/integer-gmp/src/GHC/Integer/Type.hs
index 035cb1e7ba..0d279ef1cc 100644
--- a/libraries/integer-gmp/src/GHC/Integer/Type.hs
+++ b/libraries/integer-gmp/src/GHC/Integer/Type.hs
@@ -1142,7 +1142,7 @@ shiftRNegBigNat x@(BN# xba#) n#
   where
     xn# = sizeofBigNat# x
     yn# = xn# -# nlimbs#
-    nlimbs# = quotInt# n# GMP_LIMB_BITS#
+    nlimbs# = quotInt# (n# -# 1#) GMP_LIMB_BITS#
 
 
 orBigNat :: BigNat -> BigNat -> BigNat
diff --git a/testsuite/tests/numeric/should_run/T12136.hs b/testsuite/tests/numeric/should_run/T12136.hs
new file mode 100644
index 0000000000..1f967a84bd
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T12136.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE CPP #-}
+
+#include "MachDeps.h"
+
+module Main where
+
+import Data.Bits
+
+#if WORD_SIZE_IN_BITS != 64 && WORD_SIZE_IN_BITS != 32
+# error unsupported WORD_SIZE_IN_BITS config
+#endif
+
+-- a negative integer the size of GMP_LIMB_BITS*2
+negativeBigInteger :: Integer
+negativeBigInteger = 1 - (1 `shiftL` (64 * 2))
+
+main = do
+    -- rigt shift by GMP_LIMB_BITS
+    print $ negativeBigInteger `shiftR` 64
diff --git a/testsuite/tests/numeric/should_run/T12136.stdout b/testsuite/tests/numeric/should_run/T12136.stdout
new file mode 100644
index 0000000000..e40641e6fc
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T12136.stdout
@@ -0,0 +1 @@
+-18446744073709551616
diff --git a/testsuite/tests/numeric/should_run/all.T b/testsuite/tests/numeric/should_run/all.T
index c0c4fe915c..6510dc91cd 100644
--- a/testsuite/tests/numeric/should_run/all.T
+++ b/testsuite/tests/numeric/should_run/all.T
@@ -60,3 +60,4 @@ test('T9810', normal, compile_and_run, [''])
 test('T10011', normal, compile_and_run, [''])
 test('T10962', omit_ways(['ghci']), compile_and_run, [''])
 test('T11702', extra_ways(['optasm']), compile_and_run, [''])
+test('T12136', normal, compile_and_run, [''])