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

3 files changed, 21 insertions, 0 deletions

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, [''])