Avoid libgmp aborts by imposing limits

libgmp calls ‘abort’ when given numbers too big for its
internal data structures.  The numeric limit is large and
platform-dependent; with 64-bit GMP 6.1.2 it is around
2**2**37.  Work around the problem by refusing to call libgmp
functions with arguments that would cause an abort.  With luck
libgmp will have a better way to do this in the future.
Also, introduce a variable integer-width that lets the user
control how large bignums can be.  This currently defaults
to 2**16, i.e., it allows bignums up to 2**2**16.  This
should be enough for ordinary computation, and should
help Emacs to avoid thrashing or hanging.
Problem noted by Pip Cet (Bug#32463#71).
* doc/lispref/numbers.texi, etc/NEWS:
Document recent bignum changes, including this one.
Improve documentation for bitwise operations, in the light
of bignums.
* src/alloc.c (make_number): Enforce integer-width.
(integer_overflow): New function.
(xrealloc_for_gmp, xfree_for_gmp):
Move here from emacs.c, as it's memory allocation.
(init_alloc): Initialize GMP here, rather than in emacs.c.
(integer_width): New var.
* src/data.c (GMP_NLIMBS_MAX, NLIMBS_LIMIT): New constants.
(emacs_mpz_size, emacs_mpz_mul)
(emacs_mpz_mul_2exp, emacs_mpz_pow_ui): New functions.
(arith_driver, Fash, expt_integer): Use them.
(expt_integer): New function, containing integer code
that was out of place in floatfns.c.
(check_bignum_size, xmalloc_for_gmp): Remove.
* src/emacs.c (main): Do not initialize GMP here.
* src/floatfns.c (Fexpt): Use expt_integer, which
now contains integer code moved from here.
* src/lisp.h (GMP_NUMB_BITS): Define if gmp.h doesn’t.

5 files changed, 167 insertions, 84 deletions

diff --git a/src/alloc.c b/src/alloc.c
index ddc0696ba91..24a24aab96b 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3746,33 +3746,33 @@ make_bignum_str (const char *num, int base)
 Lisp_Object
 make_number (mpz_t value)
 {
-  if (mpz_fits_slong_p (value))
-    {
-      long l = mpz_get_si (value);
-      if (!FIXNUM_OVERFLOW_P (l))
-        return make_fixnum (l);
-    }
-  else if (LONG_WIDTH < FIXNUM_BITS)
+  size_t bits = mpz_sizeinbase (value, 2);
+
+  if (bits <= FIXNUM_BITS)
     {
-      size_t bits = mpz_sizeinbase (value, 2);
+      EMACS_INT v = 0;
+      int i = 0, shift = 0;
 
-      if (bits <= FIXNUM_BITS)
-        {
-          EMACS_INT v = 0;
-          int i = 0;
-          for (int shift = 0; shift < bits; shift += mp_bits_per_limb)
-            {
-              EMACS_INT limb = mpz_getlimbn (value, i++);
-              v += limb << shift;
-            }
-          if (mpz_sgn (value) < 0)
-            v = -v;
+      do
+        {
+          EMACS_INT limb = mpz_getlimbn (value, i++);
+          v += limb << shift;
+          shift += GMP_NUMB_BITS;
+        }
+      while (shift < bits);
 
-          if (!FIXNUM_OVERFLOW_P (v))
-            return make_fixnum (v);
-        }
+      if (mpz_sgn (value) < 0)
+        v = -v;
+
+      if (!FIXNUM_OVERFLOW_P (v))
+        return make_fixnum (v);
     }
 
+  /* The documentation says integer-width should be nonnegative, so
+     a single comparison suffices even though 'bits' is unsigned.  */
+  if (integer_width < bits)
+    integer_overflow ();
+
   struct Lisp_Bignum *b = ALLOCATE_PSEUDOVECTOR (struct Lisp_Bignum, value,
                                                  PVEC_BIGNUM);
   /* We could mpz_init + mpz_swap here, to avoid a copy, but the
@@ -7200,6 +7200,26 @@ verify_alloca (void)
 
 #endif /* ENABLE_CHECKING && USE_STACK_LISP_OBJECTS */
 
+/* Memory allocation for GMP.  */
+
+void
+integer_overflow (void)
+{
+  error ("Integer too large to be represented");
+}
+
+static void *
+xrealloc_for_gmp (void *ptr, size_t ignore, size_t size)
+{
+  return xrealloc (ptr, size);
+}
+
+static void
+xfree_for_gmp (void *ptr, size_t ignore)
+{
+  xfree (ptr);
+}
+
 /* Initialization.  */
 
 void
@@ -7233,6 +7253,10 @@ init_alloc_once (void)
 void
 init_alloc (void)
 {
+  eassert (mp_bits_per_limb == GMP_NUMB_BITS);
+  integer_width = 1 << 16;
+  mp_set_memory_functions (xmalloc, xrealloc_for_gmp, xfree_for_gmp);
+
   Vgc_elapsed = make_float (0.0);
   gcs_done = 0;
 
@@ -7335,6 +7359,11 @@ The time is in seconds as a floating point value.  */);
   DEFVAR_INT ("gcs-done", gcs_done,
               doc: /* Accumulated number of garbage collections done.  */);
 
+  DEFVAR_INT ("integer-width", integer_width,
+              doc: /* Maximum number of bits in bignums.
+Integers outside the fixnum range are limited to absolute values less
+than 2**N, where N is this variable's value.  N should be nonnegative.  */);
+
   defsubr (&Scons);
   defsubr (&Slist);
   defsubr (&Svector);
diff --git a/src/data.c b/src/data.c
index 8a6975da3ab..4c6d33f2940 100644
--- a/src/data.c
+++ b/src/data.c
@@ -2384,6 +2384,80 @@ bool-vector.  IDX starts at 0.  */)
   return newelt;
 }
 
+/* GMP tests for this value and aborts (!) if it is exceeded.
+   This is as of GMP 6.1.2 (2016); perhaps future versions will differ.  */
+enum { GMP_NLIMBS_MAX = min (INT_MAX, ULONG_MAX / GMP_NUMB_BITS) };
+
+/* An upper bound on limb counts, needed to prevent libgmp and/or
+   Emacs from aborting or otherwise misbehaving.  This bound applies
+   to estimates of mpz_t sizes before the mpz_t objects are created,
+   as opposed to integer-width which operates on mpz_t values after
+   creation and before conversion to Lisp bignums.  */
+enum
+  {
+   NLIMBS_LIMIT = min (min (/* libgmp needs to store limb counts.  */
+                            GMP_NLIMBS_MAX,
+
+                            /* Size calculations need to work.  */
+                            min (PTRDIFF_MAX, SIZE_MAX) / sizeof (mp_limb_t)),
+
+                       /* Emacs puts bit counts into fixnums.  */
+                       MOST_POSITIVE_FIXNUM / GMP_NUMB_BITS)
+  };
+
+/* Like mpz_size, but tell the compiler the result is a nonnegative int.  */
+
+static int
+emacs_mpz_size (mpz_t const op)
+{
+  mp_size_t size = mpz_size (op);
+  eassume (0 <= size && size <= INT_MAX);
+  return size;
+}
+
+/* Wrappers to work around GMP limitations.  As of GMP 6.1.2 (2016),
+   the library code aborts when a number is too large.  These wrappers
+   avoid the problem for functions that can return numbers much larger
+   than their arguments.  For slowly-growing numbers, the integer
+   width check in make_number should suffice.  */
+
+static void
+emacs_mpz_mul (mpz_t rop, mpz_t const op1, mpz_t const op2)
+{
+  if (NLIMBS_LIMIT - emacs_mpz_size (op1) < emacs_mpz_size (op2))
+    integer_overflow ();
+  mpz_mul (rop, op1, op2);
+}
+
+static void
+emacs_mpz_mul_2exp (mpz_t rop, mpz_t const op1, mp_bitcnt_t op2)
+{
+  /* Fudge factor derived from GMP 6.1.2, to avoid an abort in
+     mpz_mul_2exp (look for the '+ 1' in its source code).  */
+  enum { mul_2exp_extra_limbs = 1 };
+  enum { lim = min (NLIMBS_LIMIT, GMP_NLIMBS_MAX - mul_2exp_extra_limbs) };
+
+  mp_bitcnt_t op2limbs = op2 / GMP_NUMB_BITS;
+  if (lim - emacs_mpz_size (op1) < op2limbs)
+    integer_overflow ();
+  mpz_mul_2exp (rop, op1, op2);
+}
+
+static void
+emacs_mpz_pow_ui (mpz_t rop, mpz_t const base, unsigned long exp)
+{
+  /* This fudge factor is derived from GMP 6.1.2, to avoid an abort in
+     mpz_n_pow_ui (look for the '5' in its source code).  */
+  enum { pow_ui_extra_limbs = 5 };
+  enum { lim = min (NLIMBS_LIMIT, GMP_NLIMBS_MAX - pow_ui_extra_limbs) };
+
+  int nbase = emacs_mpz_size (base), n;
+  if (INT_MULTIPLY_WRAPV (nbase, exp, &n) || lim < n)
+    integer_overflow ();
+  mpz_pow_ui (rop, base, exp);
+}
+
+
 /* Arithmetic functions */
 
 Lisp_Object
@@ -2872,13 +2946,13 @@ arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args)
           break;
         case Amult:
           if (BIGNUMP (val))
-            mpz_mul (accum, accum, XBIGNUM (val)->value);
+            emacs_mpz_mul (accum, accum, XBIGNUM (val)->value);
           else if (! FIXNUMS_FIT_IN_LONG)
             {
               mpz_t tem;
               mpz_init (tem);
               mpz_set_intmax (tem, XFIXNUM (val));
-              mpz_mul (accum, accum, tem);
+              emacs_mpz_mul (accum, accum, tem);
               mpz_clear (tem);
             }
           else
@@ -3293,7 +3367,7 @@ In this case, the sign bit is duplicated.  */)
       mpz_t result;
       mpz_init (result);
       if (XFIXNUM (count) > 0)
-        mpz_mul_2exp (result, XBIGNUM (value)->value, XFIXNUM (count));
+        emacs_mpz_mul_2exp (result, XBIGNUM (value)->value, XFIXNUM (count));
       else
         mpz_fdiv_q_2exp (result, XBIGNUM (value)->value, - XFIXNUM (count));
       val = make_number (result);
@@ -3319,7 +3393,7 @@ In this case, the sign bit is duplicated.  */)
       mpz_set_intmax (result, XFIXNUM (value));
 
       if (XFIXNUM (count) >= 0)
-        mpz_mul_2exp (result, result, XFIXNUM (count));
+        emacs_mpz_mul_2exp (result, result, XFIXNUM (count));
       else
         mpz_fdiv_q_2exp (result, result, - XFIXNUM (count));
 
@@ -3330,6 +3404,33 @@ In this case, the sign bit is duplicated.  */)
   return val;
 }
 
+/* Return X ** Y as an integer.  X and Y must be integers, and Y must
+   be nonnegative.  */
+
+Lisp_Object
+expt_integer (Lisp_Object x, Lisp_Object y)
+{
+  unsigned long exp;
+  if (TYPE_RANGED_FIXNUMP (unsigned long, y))
+    exp = XFIXNUM (y);
+  else if (MOST_POSITIVE_FIXNUM < ULONG_MAX && BIGNUMP (y)
+           && mpz_fits_ulong_p (XBIGNUM (y)->value))
+    exp = mpz_get_ui (XBIGNUM (y)->value);
+  else
+    integer_overflow ();
+
+  mpz_t val;
+  mpz_init (val);
+  emacs_mpz_pow_ui (val,
+                    (FIXNUMP (x)
+                     ? (mpz_set_intmax (val, XFIXNUM (x)), val)
+                     : XBIGNUM (x)->value),
+                    exp);
+  Lisp_Object res = make_number (val);
+  mpz_clear (val);
+  return res;
+}
+
 DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
        doc: /* Return NUMBER plus one.  NUMBER may be a number or a marker.
 Markers are converted to integers.  */)
diff --git a/src/emacs.c b/src/emacs.c
index 11ee0b81180..7d07ec85029 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -673,38 +673,6 @@ close_output_streams (void)
     _exit (EXIT_FAILURE);
 }
 
-/* Memory allocation functions for GMP.  */
-
-static void
-check_bignum_size (size_t size)
-{
-  /* Do not create a bignum whose log base 2 could exceed fixnum range.
-     This way, functions like mpz_popcount return values in fixnum range.
-     It may also help to avoid other problems with outlandish bignums.  */
-  if (MOST_POSITIVE_FIXNUM / CHAR_BIT < size)
-    error ("Integer too large to be represented");
-}
-
-static void * ATTRIBUTE_MALLOC
-xmalloc_for_gmp (size_t size)
-{
-  check_bignum_size (size);
-  return xmalloc (size);
-}
-
-static void *
-xrealloc_for_gmp (void *ptr, size_t ignore, size_t size)
-{
-  check_bignum_size (size);
-  return xrealloc (ptr, size);
-}
-
-static void
-xfree_for_gmp (void *ptr, size_t ignore)
-{
-  xfree (ptr);
-}
-
 /* ARGSUSED */
 int
 main (int argc, char **argv)
@@ -803,8 +771,6 @@ main (int argc, char **argv)
   init_standard_fds ();
   atexit (close_output_streams);
 
-  mp_set_memory_functions (xmalloc_for_gmp, xrealloc_for_gmp, xfree_for_gmp);
-
   sort_args (argc, argv);
   argc = 0;
   while (argv[argc]) argc++;
diff --git a/src/floatfns.c b/src/floatfns.c
index 7c52a0a9a20..ea9000b90a0 100644
--- a/src/floatfns.c
+++ b/src/floatfns.c
@@ -210,29 +210,7 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
   /* Common Lisp spec: don't promote if both are integers, and if the
      result is not fractional.  */
   if (INTEGERP (arg1) && NATNUMP (arg2))
-    {
-      unsigned long exp;
-      if (TYPE_RANGED_FIXNUMP (unsigned long, arg2))
-        exp = XFIXNUM (arg2);
-      else if (MOST_POSITIVE_FIXNUM < ULONG_MAX && BIGNUMP (arg2)
-               && mpz_fits_ulong_p (XBIGNUM (arg2)->value))
-        exp = mpz_get_ui (XBIGNUM (arg2)->value);
-      else
-        xsignal3 (Qrange_error, build_string ("expt"), arg1, arg2);
-
-      mpz_t val;
-      mpz_init (val);
-      if (FIXNUMP (arg1))
-        {
-          mpz_set_intmax (val, XFIXNUM (arg1));
-          mpz_pow_ui (val, val, exp);
-        }
-      else
-        mpz_pow_ui (val, XBIGNUM (arg1)->value, exp);
-      Lisp_Object res = make_number (val);
-      mpz_clear (val);
-      return res;
-    }
+    return expt_integer (arg1, arg2);
 
   return make_float (pow (XFLOATINT (arg1), XFLOATINT (arg2)));
 }
diff --git a/src/lisp.h b/src/lisp.h
index fe384d1844b..8f48a334844 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -996,6 +996,14 @@ enum More_Lisp_Bits
 #define MOST_POSITIVE_FIXNUM (EMACS_INT_MAX >> INTTYPEBITS)
 #define MOST_NEGATIVE_FIXNUM (-1 - MOST_POSITIVE_FIXNUM)
 
+
+/* GMP-related limits.  */
+
+/* Number of data bits in a limb.  */
+#ifndef GMP_NUMB_BITS
+enum { GMP_NUMB_BITS = TYPE_WIDTH (mp_limb_t) };
+#endif
+
 #if USE_LSB_TAG
 
 INLINE Lisp_Object
@@ -3338,7 +3346,7 @@ extern void set_internal (Lisp_Object, Lisp_Object, Lisp_Object,
                           enum Set_Internal_Bind);
 extern void set_default_internal (Lisp_Object, Lisp_Object,
                                   enum Set_Internal_Bind bindflag);
-
+extern Lisp_Object expt_integer (Lisp_Object, Lisp_Object);
 extern void syms_of_data (void);
 extern void swap_in_global_binding (struct Lisp_Symbol *);
 
@@ -3700,6 +3708,7 @@ extern void display_malloc_warning (void);
 extern ptrdiff_t inhibit_garbage_collection (void);
 extern Lisp_Object build_overlay (Lisp_Object, Lisp_Object, Lisp_Object);
 extern void free_cons (struct Lisp_Cons *);
+extern _Noreturn void integer_overflow (void);
 extern void init_alloc_once (void);
 extern void init_alloc (void);
 extern void syms_of_alloc (void);