common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Fix bignum-to-float overflow detection.

Browse source 
A truly-the type declaration defeated the check.
This commit is contained in:
Stas Boukarev 2025-08-22 19:28:45 +03:00
parent 3b5c9e4a0f
commit 149ce4b249
2 changed files with 63 additions and 55 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

113
src/code/bignum.lisp
View file

@ -1467,66 +1467,69 @@
(let ((bignum-length (%bignum-length bignum)))
;; word-sized bignums shouldn't reach here
(declare ((integer 2) bignum-length))
(,(case type
(single-float 'sb-kernel:make-single-float)
(double-float 'sb-kernel:%make-double-float))
(if (%bignum-0-or-plusp bignum bignum-length)
(let* ((length (truly-the bignum-length (bignum-buffer-integer-length bignum bignum-length)))
(shift (- length ,(const 'digits) 1)) ;; Get one more bit for rounding
(shifted (truly-the fixnum
(last-bignum-part=>fixnum (- sb-bignum::digit-size ,(const 'digits))
shift bignum)))
(signif (ldb (byte (byte-size ,(const 'significand-byte)) ; Cut off the hidden bit
1) ; and the rounding bit
shifted))
(exp (truly-the (unsigned-byte ,(byte-size sb-vm:double-float-exponent-byte))
(+ ,(const 'bias) length)))
(bits (ash exp
(byte-position ,(const 'exponent-byte)))))
(when (and (logtest shifted 1)
(or (logtest signif 1)
(not (bignum-lower-bits-zero-p bignum shift bignum-length))))
;; Round up
(incf signif))
;; If rounding up overflows this will increase the exponent too
(let ((bits (+ bits signif)))
(when (or (> exp ,(const 'normal-exponent-max))
;; Overflow after rounding up
(= bits (,(const 'bits) ,(const 'positive-infinity))))
(error 'floating-point-overflow
:operation 'float
:operands (list bignum ',type)))
(truly-the sb-vm:signed-word bits)))
(multiple-value-bind (last1 last2) (bignum-negate-last-two bignum bignum-length)
(let* ((last2-length (integer-length last2))
(length (+ last2-length (* (1- bignum-length) digit-size)))
(shift (- length ,(const 'digits) 1))
(bit-index (rem shift digit-size))
(shifted (cond ((zerop last2)
(truly-the word (ash last1 (- bit-index))))
((<= bit-index (- digit-size (1+ ,(const 'digits))))
(truly-the word (ash last2 (- bit-index))))
(t
(logand most-positive-word
(logior (ash last2 (- digit-size bit-index))
(ash last1 (- bit-index)))))))
(signif (ldb ,(const 'significand-byte) (ash shifted -1)))
(exp (truly-the (unsigned-byte 11) (+ ,(const 'bias) length)))
(bits (ash exp (byte-position ,(const 'exponent-byte)))))
(flet ((overflow ()
(error 'floating-point-overflow
:operation 'float
:operands (list bignum ',type))))
(,(case type
(single-float 'sb-kernel:make-single-float)
(double-float 'sb-kernel:%make-double-float))
(if (%bignum-0-or-plusp bignum bignum-length)
(let* ((length (truly-the bignum-length (bignum-buffer-integer-length bignum bignum-length)))
(shift (- length ,(const 'digits) 1)) ;; Get one more bit for rounding
(shifted (truly-the fixnum
(last-bignum-part=>fixnum (- sb-bignum::digit-size ,(const 'digits))
shift bignum)))
(signif (ldb (byte (byte-size ,(const 'significand-byte)) ; Cut off the hidden bit
1) ; and the rounding bit
shifted))
(exp (let ((exp (+ ,(const 'bias) length)))
(if (> exp ,(const 'normal-exponent-max))
(overflow)
exp)))
(bits (ash exp
(byte-position ,(const 'exponent-byte)))))
(when (and (logtest shifted 1)
(or (logtest signif 1)
(not (bignum-lower-bits-zero-p bignum shift bignum-length))))
;; Round up
(incf signif))
;; If rounding up overflows this will increase the exponent too
(let ((bits (+ bits signif)))
(when (or (> exp ,(const 'normal-exponent-max))
(= bits (,(const 'bits) ,(const 'positive-infinity))))
(error 'floating-point-overflow
:operation 'float
:operands (list bignum ',type)))
(logior (ash -1 ,(case type
(double-float 63)
(single-float 31)))
(truly-the sb-vm:signed-word bits))))))))))))
;; Overflow after rounding up
(when (= bits (,(const 'bits) ,(const 'positive-infinity)))
(overflow))
(truly-the sb-vm:signed-word bits)))
(multiple-value-bind (last1 last2) (bignum-negate-last-two bignum bignum-length)
(let* ((last2-length (integer-length last2))
(length (+ last2-length (* (1- bignum-length) digit-size)))
(shift (- length ,(const 'digits) 1))
(bit-index (rem shift digit-size))
(shifted (cond ((zerop last2)
(truly-the word (ash last1 (- bit-index))))
((<= bit-index (- digit-size (1+ ,(const 'digits))))
(truly-the word (ash last2 (- bit-index))))
(t
(logand most-positive-word
(logior (ash last2 (- digit-size bit-index))
(ash last1 (- bit-index)))))))
(signif (ldb ,(const 'significand-byte) (ash shifted -1)))
(exp (let ((exp (+ ,(const 'bias) length)))
(if (> exp ,(const 'normal-exponent-max))
(overflow)
exp)))
(bits (ash exp (byte-position ,(const 'exponent-byte)))))
(when (and (logtest shifted 1)
(or (logtest signif 1)
(not (bignum-lower-bits-zero-p bignum shift bignum-length))))
(incf signif))
(let ((bits (+ bits signif)))
(when (= bits (,(const 'bits) ,(const 'positive-infinity)))
(overflow))
(logior (ash -1 ,(case type
(double-float 63)
(single-float 31)))
(truly-the sb-vm:signed-word bits)))))))))))))
(def single-float)
(def double-float))

5
tests/float-2.pure.lisp
View file

@ -127,6 +127,11 @@
do (format nil "~E~%" n))
floating-point-overflow))
(with-test (:name :bignum-double-float-overflow)
(loop for n from 1024 to 1030
do (assert-error (coerce (opaque-identity (expt 2 n)) 'double-float) floating-point-overflow)
(assert-error (coerce (opaque-identity (- (expt 2 n))) 'double-float) floating-point-overflow)))
;; 1.0.29.44 introduces a ton of changes for complex floats
;; on x86-64. Huge test of doom to help catch weird corner
;; cases.