unofficial mirror of bug-guile@gnu.org 
 help / color / mirror / Atom feed
From: lloda <lloda@sarc.name>
To: 50609@debbugs.gnu.org
Subject: bug#50609: number overflow
Date: Thu, 4 Nov 2021 20:12:10 +0100	[thread overview]
Message-ID: <B96F91EE-D45E-4167-86E9-5F785D7356C5@sarc.name> (raw)
In-Reply-To: <CAGua6m1KS6P7sOJeM4xgrAt7cex440tG3K5xgxpUk_LsogAD4g@mail.gmail.com>

[-- Attachment #1: Type: text/plain, Size: 174 bytes --]


Not quite comfortable poking around in the compiler, but find a patch attached.

I also found this related bug: https://debbugs.gnu.org/cgi/bugreport.cgi?bug=32644.



[-- Attachment #2: 0001-Limit-the-range-of-ash-round-ash-count-argument-to-I.patch --]
[-- Type: application/octet-stream, Size: 6413 bytes --]

From 699919f181ea94ba00d392b49d07ed85e7535fcc Mon Sep 17 00:00:00 2001
From: Daniel Llorens <lloda@sarc.name>
Date: Thu, 4 Nov 2021 14:52:21 +0100
Subject: [PATCH 1/2] Limit the range of ash, round-ash count argument to INT32

This avoids gmp aborting e.g. with (ash 1 (expt 2 37)). The new limit is
such that (ash 1 (expt 30)) is accepted but (ash 1 (expt 31)) throws.

* libguile/numbers.c (ash, round-ash): As stated.
* test-suite/tests/numbers.test: Test a case known to make gmp abort before.
---
 libguile/numbers.c            | 98 +++++++++++++++--------------------
 test-suite/tests/numbers.test |  5 +-
 2 files changed, 47 insertions(+), 56 deletions(-)

diff --git a/libguile/numbers.c b/libguile/numbers.c
index 18bd22dbb..1f7785aa6 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -5090,6 +5090,8 @@ round_right_shift_exact_integer (SCM n, long count)
    and moreover that they can be negated without overflow. */
 verify (SCM_MOST_NEGATIVE_FIXNUM >= LONG_MIN + 1
         && SCM_MOST_POSITIVE_FIXNUM <= LONG_MAX);
+/* the practicable limits are smaller */
+verify (INT32_MIN >= LONG_MIN && INT32_MAX <= LONG_MAX);
 
 SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
             (SCM n, SCM count),
@@ -5110,35 +5112,28 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
 	    "@end lisp")
 #define FUNC_NAME s_scm_ash
 {
-  if (SCM_I_INUMP (n) || SCM_BIGP (n))
-    {
-      long bits_to_shift;
-
-      if (SCM_I_INUMP (count))  /* fast path, not strictly needed */
-        bits_to_shift = SCM_I_INUM (count);
-      else if (scm_is_signed_integer (count, LONG_MIN + 1, LONG_MAX))
-        /* We exclude LONG_MIN to ensure that 'bits_to_shift' can be
-           negated without overflowing. */
-        bits_to_shift = scm_to_long (count);
-      else if (scm_is_false (scm_positive_p (scm_sum (scm_integer_length (n),
-                                                      count))))
-        /* Huge right shift that eliminates all but the sign bit */
-        return scm_is_false (scm_negative_p (n))
-          ? SCM_INUM0 : SCM_I_MAKINUM (-1);
-      else if (scm_is_true (scm_zero_p (n)))
-        return SCM_INUM0;
-      else
-        scm_num_overflow ("ash");
-
-      if (bits_to_shift > 0)
-        return left_shift_exact_integer (n, bits_to_shift);
-      else if (SCM_LIKELY (bits_to_shift < 0))
-        return floor_right_shift_exact_integer (n, -bits_to_shift);
-      else
-        return n;
-    }
-  else
+  if (!SCM_I_INUMP (n) && !SCM_BIGP (n))
     SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
+  
+  if (scm_is_false (scm_positive_p (scm_sum (scm_integer_length (n),
+                                             count))))
+    /* Huge right shift that eliminates all but the sign bit */
+    return scm_is_false (scm_negative_p (n))
+      ? SCM_INUM0 : SCM_I_MAKINUM (-1);
+  else if (scm_is_true (scm_zero_p (n)))
+    return SCM_INUM0;
+  else if (scm_is_signed_integer (count, INT32_MIN + 1, INT32_MAX)) {
+    /* We exclude MIN to ensure that 'bits_to_shift' can be
+       negated without overflowing, if INT32_MIN happens to be LONG_MIN */
+    long bits_to_shift = scm_to_long (count);
+    if (bits_to_shift > 0)
+      return left_shift_exact_integer (n, bits_to_shift);
+    else if (SCM_LIKELY (bits_to_shift < 0))
+      return floor_right_shift_exact_integer (n, -bits_to_shift);
+    else
+      return n;
+  } else
+    scm_num_overflow ("ash");
 }
 #undef FUNC_NAME
 
@@ -5164,34 +5159,27 @@ SCM_DEFINE (scm_round_ash, "round-ash", 2, 0, 0,
 	    "@end lisp")
 #define FUNC_NAME s_scm_round_ash
 {
-  if (SCM_I_INUMP (n) || SCM_BIGP (n))
-    {
-      long bits_to_shift;
-
-      if (SCM_I_INUMP (count))  /* fast path, not strictly needed */
-        bits_to_shift = SCM_I_INUM (count);
-      else if (scm_is_signed_integer (count, LONG_MIN + 1, LONG_MAX))
-        /* We exclude LONG_MIN to ensure that 'bits_to_shift' can be
-           negated without overflowing. */
-        bits_to_shift = scm_to_long (count);
-      else if (scm_is_true (scm_negative_p (scm_sum (scm_integer_length (n),
-                                                     count)))
-               || scm_is_true (scm_zero_p (n)))
-        /* If N is zero, or the right shift count exceeds the integer
-           length, the result is zero. */
-        return SCM_INUM0;
-      else
-        scm_num_overflow ("round-ash");
-
-      if (bits_to_shift > 0)
-        return left_shift_exact_integer (n, bits_to_shift);
-      else if (SCM_LIKELY (bits_to_shift < 0))
-        return round_right_shift_exact_integer (n, -bits_to_shift);
-      else
-        return n;
-    }
-  else
+  if (!SCM_I_INUMP (n) && !SCM_BIGP (n))
     SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
+  
+  if (scm_is_true (scm_negative_p (scm_sum (scm_integer_length (n),
+                                            count)))
+      || scm_is_true (scm_zero_p (n)))
+    /* If N is zero, or the right shift count exceeds the integer
+       length, the result is zero. */
+    return SCM_INUM0;
+  else if (scm_is_signed_integer (count, INT32_MIN + 1, INT32_MAX)) {
+    /* We exclude MIN to ensure that 'bits_to_shift' can be
+       negated without overflowing, if INT32_MIN happens to be LONG_MIN */
+    long bits_to_shift = scm_to_long (count);
+    if (bits_to_shift > 0)
+      return left_shift_exact_integer (n, bits_to_shift);
+    else if (SCM_LIKELY (bits_to_shift < 0))
+      return round_right_shift_exact_integer (n, -bits_to_shift);
+    else
+      return n;
+  } else 
+    scm_num_overflow ("round-ash");
 }
 #undef FUNC_NAME
 
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 8f644874d..51263f0ac 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -5466,7 +5466,10 @@
         (ash-variant -1 (- (expt 2 1000))))
       (pass-if-exception "Huge left shift of non-zero => numerical overflow"
           exception:numerical-overflow
-        (ash-variant 123 (expt 2 1000)))))
+        (ash-variant 123 (expt 2 1000)))
+      (pass-if-exception "Shift large enough to cause gmp abort in 3.0.7"
+          exception:numerical-overflow
+        (ash-variant 1 (expt 2 37)))))
 
   (test-ash-variant       'ash       ash floor #f)
   (test-ash-variant 'round-ash round-ash round #t)
-- 
2.33.1


[-- Attachment #3: 0002-Avoid-ash-with-arguments-that-might-overflow-in-lang.patch --]
[-- Type: application/octet-stream, Size: 1083 bytes --]

From 47f99500e68e40f34a1dab8b0350f32c2ed62d9d Mon Sep 17 00:00:00 2001
From: Daniel Llorens <lloda@sarc.name>
Date: Thu, 4 Nov 2021 16:02:42 +0100
Subject: [PATCH 2/2] Avoid ash with arguments that might overflow in (language
 cps types)

Fixes https://debbugs.gnu.org/50609

* module/languages/cps/types.scm (ulsh): As stated.
---
 module/language/cps/types.scm | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index d3be176bf..87c58d5bc 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1444,7 +1444,9 @@ minimum, and maximum."
         (define! result &s64 &s64-min &s64-max))))
 
 (define-type-inferrer (ulsh a b result)
-  (if (<= (ash (&max/u64 a) (&max/u64 b)) &u64-max)
+  (if (and
+       (or (zero? (&max/u64 a)) (< (&max/u64 b) 64)) ; don't even try
+       (<= (ash (&max/u64 a) (&max/u64 b)) &u64-max))
       ;; No overflow; we can be precise.
       (define! result &u64
         (ash (&min/0 a) (&min/0 b))
-- 
2.33.1


[-- Attachment #4: Type: text/plain, Size: 2 bytes --]




  reply	other threads:[~2021-11-04 19:12 UTC|newest]

Thread overview: 3+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2021-09-15 19:12 bug#50609: number overflow Stefan Israelsson Tampe
2021-11-04 19:12 ` lloda [this message]
2021-11-05 16:35 ` lloda

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://www.gnu.org/software/guile/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=B96F91EE-D45E-4167-86E9-5F785D7356C5@sarc.name \
    --to=lloda@sarc.name \
    --cc=50609@debbugs.gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).