[commit: ghc] master: Fix the right-shift operation for negative big integers (fixes #12136) (06b9561)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/06b9561a2f10de68cc14b68a9bfa7617c0019bd9/ghc

>---------------------------------------------------------------

commit 06b9561a2f10de68cc14b68a9bfa7617c0019bd9
Author: Daishi Nakajima <nakaji.dayo at gmail.com>
Date:   Thu Jan 26 18:14:08 2017 -0500

    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


>---------------------------------------------------------------

06b9561a2f10de68cc14b68a9bfa7617c0019bd9
 libraries/integer-gmp/cbits/wrappers.c           | 14 +++++++++++---
 libraries/integer-gmp/src/GHC/Integer/Type.hs    |  2 +-
 testsuite/tests/numeric/should_run/T12136.hs     | 19 +++++++++++++++++++
 testsuite/tests/numeric/should_run/T12136.stdout |  1 +
 testsuite/tests/numeric/should_run/all.T         |  1 +
 5 files changed, 33 insertions(+), 4 deletions(-)

diff --git a/libraries/integer-gmp/cbits/wrappers.c b/libraries/integer-gmp/cbits/wrappers.c
index 1736efd..c99c017 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 035cb1e..0d279ef 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 0000000..1f967a8
--- /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 0000000..e40641e
--- /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 c0c4fe9..6510dc9 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, [''])