* bug#50609: number overflow
@ 2021-09-15 19:12 Stefan Israelsson Tampe
2021-11-04 19:12 ` lloda
2021-11-05 16:35 ` lloda
0 siblings, 2 replies; 3+ messages in thread
From: Stefan Israelsson Tampe @ 2021-09-15 19:12 UTC (permalink / raw)
To: 50609
[-- Attachment #1: Type: text/plain, Size: 312 bytes --]
This does not compile on guile 3.0.7,
(define (f . l)
(let lp2 ((i 0) (s 0) (l l))
(if (and (pair? l) (< i 64))
(lp2 (+ i 1) (if (car l) (logior (ash 1 i) s) s) (cdr l))
s)))
While compiling expression:
Throw to key `numerical-overflow' with args `("ash" "Numerical ove
rflow" #f #f)'.
[-- Attachment #2: Type: text/html, Size: 701 bytes --]
^ permalink raw reply [flat|nested] 3+ messages in thread
* bug#50609: number overflow
2021-09-15 19:12 bug#50609: number overflow Stefan Israelsson Tampe
@ 2021-11-04 19:12 ` lloda
2021-11-05 16:35 ` lloda
1 sibling, 0 replies; 3+ messages in thread
From: lloda @ 2021-11-04 19:12 UTC (permalink / raw)
To: 50609
[-- 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 --]
^ permalink raw reply related [flat|nested] 3+ messages in thread
* bug#50609: number overflow
2021-09-15 19:12 bug#50609: number overflow Stefan Israelsson Tampe
2021-11-04 19:12 ` lloda
@ 2021-11-05 16:35 ` lloda
1 sibling, 0 replies; 3+ messages in thread
From: lloda @ 2021-11-05 16:35 UTC (permalink / raw)
To: 50609-done
I've applied the patch in c6b1171c6b5632ac04120f482af786444e17d3fe. Thanks for the report!
^ permalink raw reply [flat|nested] 3+ messages in thread
end of thread, other threads:[~2021-11-05 16:35 UTC | newest]
Thread overview: 3+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-09-15 19:12 bug#50609: number overflow Stefan Israelsson Tampe
2021-11-04 19:12 ` lloda
2021-11-05 16:35 ` lloda
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).