From 673a3d8ab8b7d158fba743ebffdd8c79214f27b0 Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Wed, 28 Jan 2026 07:25:45 +0300 Subject: [PATCH] Fix scale-float rounding for subnormals Shifting right discards some set bits. Rely on the FPU multiplication instead. --- COPYING | 9 ++ src/code/cross-float-reader.lisp | 3 +- src/code/early-extensions.lisp | 72 +++++++++++++ src/code/float.lisp | 180 +++++++++++++++++++++---------- src/code/target-float.lisp | 87 --------------- src/cold/build-order.lisp-expr | 2 +- src/compiler/ir1opt.lisp | 5 +- src/compiler/ir1util.lisp | 13 ++- src/compiler/macros.lisp | 62 ----------- tests/compiler.pure.lisp | 12 +-- tests/float-2.pure.lisp | 4 + 11 files changed, 228 insertions(+), 221 deletions(-) diff --git a/COPYING b/COPYING index 3bfcb68f2..4220b3397 100644 --- a/COPYING +++ b/COPYING @@ -112,3 +112,12 @@ Gerd Moellmann are retained. ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;;; DAMAGE. + +;;; ==================================================== +;;; Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. +;;; +;;; Developed at SunPro, a Sun Microsystems, Inc. business. +;;; Permission to use, copy, modify, and distribute this +;;; software is freely granted, provided that this notice +;;; is preserved. +;;; ==================================================== diff --git a/src/code/cross-float-reader.lisp b/src/code/cross-float-reader.lisp index 5398c72d6..2043f20c0 100644 --- a/src/code/cross-float-reader.lisp +++ b/src/code/cross-float-reader.lisp @@ -15,7 +15,8 @@ (let ((initial-exponent (1- (ash 1 (1- n-exponent-bits)))) (max-exponent (1- (ash 1 n-exponent-bits)))) `(defun ,name (rational) - (declare (type cl:rational rational)) + (declare (type cl:rational rational) + (notinline ,bits-fun)) (let ((sign (if (cl:= (cl:signum rational) -1) 1 0)) (magnitude (cl:abs rational))) (when (cl:= magnitude 0) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 918270b07..93be28a8f 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -1521,5 +1521,77 @@ NOTE: This interface is experimental and subject to change." (<= (- exponent) ;; count-trailing-zeros, but wider for 32-bit platforms (integer-length (ldb (byte 64 0) (lognor significand (- significand))))))))) + +(defmacro make-defs (vars &body body) + (labels ((subst-if-with (test tree) + (labels ((s (subtree) + (multiple-value-bind (new replace) + (funcall test subtree) + (cond (replace new) + ((comma-p subtree) + (let ((new (s (comma-expr subtree)))) + (if (eq subtree new) + subtree + (unquote new (comma-kind subtree))))) + ((atom subtree) subtree) + (t (let ((car (s (car subtree))) + (cdr (s (cdr subtree)))) + (if (and (eq car (car subtree)) + (eq cdr (cdr subtree))) + subtree + (cond ((and (typep car '(cons symbol)) + (string= (car car) "$WHEN")) + (if (eval (second car)) + (append (cddr car) cdr) + cdr)) + ((and (typep car '(cons symbol)) + (string= (car car) "$UNLESS")) + (if (eval (second car)) + cdr + (append (cddr car) cdr))) + ((and (typep car '(cons symbol)) + (string= (car car) "$IF")) + (cons + (if (eval (second car)) + (third car) + (fourth car)) + cdr)) + (t + (cons car cdr)))))))))) + (s tree))) + (test (pattern with) + (lambda (x) + (when (symbolp x) + (let* ((str (string x)) + (start (search pattern str))) + (when start + (values + (if (equal str pattern) + with + (let ((package (position #\: str))) + (if package + (package-symbolicate (subseq str 0 package) + (subseq str (1+ package) start) + with + (subseq str (+ start (length pattern)))) + (symbolicate (subseq str 0 start) + with + (subseq str (+ start (length pattern))))))) + t)))))) + (gen (vars body) + (if vars + (loop for with in (cdar vars) + append + (gen (cdr vars) + (let ((body body) + (patterns (sort (loop for v in (ensure-list (caar vars)) + for w in (ensure-list with) + collect (cons v w)) + #'> :key (lambda (x) (length (string (car x))))))) + (loop for (v . w) in patterns + do (setf body (subst-if-with (test (string v) w) body))) + body))) + body))) + `(progn ,@(gen vars body)))) (defvar *top-level-form-p* nil) diff --git a/src/code/float.lisp b/src/code/float.lisp index 577d76ccd..2724402d2 100644 --- a/src/code/float.lisp +++ b/src/code/float.lisp @@ -573,65 +573,131 @@ (declaim (maybe-inline scale-single-float scale-double-float)) -;;; Scale a single or double float, calling the correct over/underflow -;;; functions. -(defun scale-single-float (x exp) - (declare (single-float x) (integer exp)) - (etypecase exp - (fixnum - (let* ((bits (single-float-bits x)) - (old-exp (ldb sb-vm:single-float-exponent-byte bits)) - (new-exp (+ old-exp exp))) - (cond - ((zerop x) x) - ((or (< old-exp sb-vm:single-float-normal-exponent-min) - (< new-exp sb-vm:single-float-normal-exponent-min)) - (scale-single-float-maybe-underflow x exp)) - ((or (> old-exp sb-vm:single-float-normal-exponent-max) - (> new-exp sb-vm:single-float-normal-exponent-max)) - (scale-single-float-maybe-overflow x exp)) - (t - (make-single-float (dpb new-exp - sb-vm:single-float-exponent-byte - bits)))))) - (unsigned-byte (scale-single-float-maybe-overflow x exp)) - ((integer * 0) (scale-single-float-maybe-underflow x exp)))) +;; ==================================================== +;; Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. +;; +;; Developed at SunPro, a Sun Microsystems, Inc. business. +;; Permission to use, copy, modify, and distribute this +;; software is freely granted, provided that this notice +;; is preserved. +;; ==================================================== +(make-defs ((($type $make $tiny $huge $two^ $two^- $size) + (single-float make-single-float + 1f-30 1f30 3.355443200f7 2.9802322388f-8 31) + #+64-bit + (double-float %make-double-float + 1d-300 1d300 1.80143985094819840000d16 5.55111512312578270212d-17 63))) + (defun scale-$type (float n) + (declare ($type float) + (integer n) + (optimize speed)) + (block scale-$type + (let* ((1+digits (1+ sb-vm\:$type-digits)) + (two^digits $two^) + (two^-digits $two^-) + (tiny $tiny) + (huge $huge) + (bits ($type-bits float)) + (exp (ldb sb-vm\:$type-exponent-byte bits))) -(defun scale-double-float (x exp) - (etypecase exp - (fixnum - #+64-bit - (let* ((bits (double-float-bits x)) - (old-exp (ldb sb-vm:double-float-exponent-byte bits)) - (new-exp (+ old-exp exp))) - (cond - ((zerop x) x) - ((or (< old-exp sb-vm:double-float-normal-exponent-min) - (< new-exp sb-vm:double-float-normal-exponent-min)) - (scale-double-float-maybe-underflow x exp)) - ((or (> old-exp sb-vm:double-float-normal-exponent-max) - (> new-exp sb-vm:double-float-normal-exponent-max)) - (scale-double-float-maybe-overflow x exp)) + ;; 0 or subnormal x + (when (zerop exp) + (when (zerop (ldb (byte $size 0) bits)) + ;; +-0 + (return-from scale-$type float)) + + (setf float (sb-xc:* float two^digits) + bits ($type-bits float) + exp (- (ldb sb-vm\:$type-exponent-byte bits) + 1+digits))) + + ;; NaN or Inf + (when (= exp (1+ sb-vm\:$type-normal-exponent-max)) + (return-from scale-$type (sb-xc:+ float float))) + + (if (typep n 'fixnum) + (cond + ((> n 5000) + (return-from scale-$type (sb-xc:* huge (float-sign float huge)))) + ((< n -5000) + (return-from scale-$type (sb-xc:* tiny (float-sign float tiny))))) + (if (plusp n) + (return-from scale-$type (sb-xc:* huge (float-sign float huge))) + (return-from scale-$type (sb-xc:* tiny (float-sign float tiny))))) + (let ((exp-new (+ exp n))) + (declare (type fixnum exp-new)) + (cond ((plusp exp-new) + (cond + ;; Overflow + ((> exp-new sb-vm\:$type-normal-exponent-max) + (sb-xc:* huge (float-sign float huge))) + ;; normal result + (t + ($make + (dpb exp-new sb-vm\:$type-exponent-byte bits))))) + ((<= exp-new (- 1+digits)) + ;; Underflow + (sb-xc:* tiny (float-sign float tiny))) + (t + ;; subnormal result + (sb-xc:* ($make + (dpb (+ exp-new 1+digits) + sb-vm\:$type-exponent-byte + bits)) + two^-digits)))))))) + +#-64-bit +(defun scale-double-float (float n) + (declare (double-float float) + (integer n)) + (block scale-double-float + (let* ((1+digits (1+ sb-vm:double-float-digits)) + (two^digits 1.8014398509481984d16) + (two^-digits 5.551115123125783d-17) + (tiny 1.0d-300) + (huge 1.0d300) + (lo-bits (double-float-low-bits float)) + (hi-bits (double-float-high-bits float)) + (exp (ldb sb-vm:double-float-hi-exponent-byte hi-bits))) + (when (zerop exp) + (when (zerop (logior (ldb (byte 31 0) hi-bits) lo-bits)) + (return-from scale-double-float float)) + (setf float (sb-xc:* float two^digits) + lo-bits (double-float-low-bits float) + hi-bits (double-float-high-bits float) + exp (- (ldb sb-vm:double-float-hi-exponent-byte hi-bits) + 1+digits))) + (when (= exp (1+ sb-vm:double-float-normal-exponent-max)) + (return-from scale-double-float (sb-xc:+ float float))) + (if (typep n 'fixnum) + (cond + ((> n 5000) + (return-from scale-double-float (sb-xc:* huge (float-sign float huge)))) + ((< n -5000) + (return-from scale-double-float (sb-xc:* tiny (float-sign float tiny))))) + (if (plusp n) + (return-from scale-double-float (sb-xc:* huge (float-sign float huge))) + (return-from scale-double-float + (sb-xc:* tiny (float-sign float tiny))))) + (let ((exp-new (+ exp n))) + (declare (type fixnum exp-new)) + (cond + ((plusp exp-new) + (cond + ((> exp-new sb-vm:double-float-normal-exponent-max) + (sb-xc:* huge (float-sign float huge))) + (t + (make-double-float + (dpb exp-new sb-vm:double-float-hi-exponent-byte hi-bits) + lo-bits)))) + ((<= exp-new (- 1+digits)) (sb-xc:* tiny (float-sign float tiny))) (t - (%make-double-float (dpb new-exp sb-vm:double-float-exponent-byte bits))))) - #-64-bit - (let* ((hi (double-float-high-bits x)) - (lo (double-float-low-bits x)) - (old-exp (ldb sb-vm:double-float-hi-exponent-byte hi)) - (new-exp (+ old-exp exp))) - (cond - ((zerop x) x) - ((or (< old-exp sb-vm:double-float-normal-exponent-min) - (< new-exp sb-vm:double-float-normal-exponent-min)) - (scale-double-float-maybe-underflow x exp)) - ((or (> old-exp sb-vm:double-float-normal-exponent-max) - (> new-exp sb-vm:double-float-normal-exponent-max)) - (scale-double-float-maybe-overflow x exp)) - (t - (make-double-float (dpb new-exp sb-vm:double-float-hi-exponent-byte hi) - lo))))) - (unsigned-byte (scale-double-float-maybe-overflow x exp)) - ((integer * 0) (scale-double-float-maybe-underflow x exp)))) + (sb-xc:* + (make-double-float + (dpb (+ exp-new 1+digits) sb-vm:double-float-hi-exponent-byte + hi-bits) + lo-bits) + two^-digits))))))) ;;; Dispatch to the correct type-specific scale-float function. (defun scale-float (f ex) diff --git a/src/code/target-float.lisp b/src/code/target-float.lisp index cf8446fe5..e36506b90 100644 --- a/src/code/target-float.lisp +++ b/src/code/target-float.lisp @@ -15,93 +15,6 @@ (in-package "SB-KERNEL") -;;; Handle float scaling where the X is denormalized or the result is -;;; denormalized or underflows to 0. -(macrolet ((def (type) - `(defun ,(symbolicate 'scale- type '-maybe-underflow) (x exp) - (declare (inline ,(symbolicate 'integer-decode- type))) - (cond ((float-infinity-p x) - x) - ((float-nan-p x) - (when (and (float-trapping-nan-p x) - (sb-vm:current-float-trap :invalid)) - (error 'floating-point-invalid-operation :operation 'scale-float - :operands (list x exp))) - x) - (t - (multiple-value-bind (sig old-exp sign) (,(symbolicate 'integer-decode- type) x) - (let* ((digits (float-digits x)) - ;; Normalize the significand if it's denormal - (shift (- digits (integer-length sig))) - (sig (truly-the ,(symbolicate type '-significand) - (ash sig shift))) - (old-exp (- old-exp shift)) - (new-exp (+ exp old-exp digits - ,(case type - (single-float 'sb-vm:single-float-bias) - (double-float 'sb-vm:double-float-bias)))) - ;; convert decoded values {-1,+1} into {1,0} respectively - (sign (if (minusp sign) 1 0))) - (cond - ((< new-exp - ,(case type - (single-float 'sb-vm:single-float-normal-exponent-min) - (double-float 'sb-vm:double-float-normal-exponent-min))) - (when (sb-vm:current-float-trap :inexact) - (error 'floating-point-inexact :operation 'scale-float - :operands (list x exp))) - (when (sb-vm:current-float-trap :underflow) - (error 'floating-point-underflow :operation 'scale-float - :operands (list x exp))) - (let ((shift (1- new-exp))) - (if (< shift (- (1- digits))) - (float-sign x ,(case type - (single-float 0f0) - (double-float 0d0))) - ,(case type - (single-float '(single-from-bits sign 0 (ash sig shift))) - (double-float '(double-from-bits sign 0 (ash sig shift))))))) - (t - ,(case type - (single-float '(single-from-bits sign new-exp sig)) - (double-float '(double-from-bits sign new-exp sig)))))))))))) - (def single-float) - (def double-float)) - -;;; Called when scaling a float overflows, or the original float was a -;;; NaN or infinity. If overflow errors are trapped, then error, -;;; otherwise return the appropriate infinity. If a NaN, signal or not -;;; as appropriate. -(macrolet ((def (type) - `(defun ,(symbolicate 'scale- type '-maybe-overflow) (x exp) - (cond - ((float-infinity-p x) - ;; Infinity is infinity, no matter how small... - x) - ((float-nan-p x) - (when (and (float-trapping-nan-p x) - (sb-vm:current-float-trap :invalid)) - (error 'floating-point-invalid-operation :operation 'scale-float - :operands (list x exp))) - x) - (t - (when (sb-vm:current-float-trap :overflow) - (error 'floating-point-overflow :operation 'scale-float - :operands (list x exp))) - (when (sb-vm:current-float-trap :inexact) - (error 'floating-point-inexact :operation 'scale-float - :operands (list x exp))) - (* (float-sign x) - ,(ecase type - (single-float - ;; SINGLE-FLOAT-POSITIVE-INFINITY - `(single-from-bits 0 (1+ sb-vm:single-float-normal-exponent-max) 0)) - (double-float - ;; DOUBLE-FLOAT-POSITIVE-INFINITY - `(double-from-bits 0 (1+ sb-vm:double-float-normal-exponent-max) 0))))))))) - (def single-float) - (def double-float)) - ;;; This algorithm for RATIONALIZE, due to Bruno Haible, is included ;;; with permission. ;;; diff --git a/src/cold/build-order.lisp-expr b/src/cold/build-order.lisp-expr index 1ddcb9b23..a84dbf4e1 100644 --- a/src/cold/build-order.lisp-expr +++ b/src/cold/build-order.lisp-expr @@ -162,8 +162,8 @@ ("src/code/debug-var-io") ("src/code/number-dispatch" :c-headers) - ("src/code/float" :c-headers) ("src/code/cross-float-reader" :c-headers :not-target) + ("src/code/float" :c-headers) ("src/code/cross-float" :c-headers :not-target) ;; 32-bit implementation of GET-INTERNAL-REAL-TIME needs some thread slots diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 08f4042b8..79f2f542e 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -1992,12 +1992,13 @@ (fold-p (fun-info-fold-p info))) (when (or (not fold-p) (apply fold-p args)) - (multiple-value-bind (values win) (careful-call (or folder + (multiple-value-bind (values win ignore) (careful-call (or folder fun-name) args) (cond ((not win) ;; Ignore errors from dedicated folders, in lieu of adding fun-info-fold-p. - (unless folder + (unless (or folder + ignore) (setf (combination-kind call) :error (combination-info call) (list #'compiler-style-warn "Lisp error during constant folding:~%~A" values)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index c85b1e13d..80c485e29 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -3268,9 +3268,18 @@ is :ANY, the function name is not checked." (defun careful-call (function args) (declare (type (or symbol function) function) (type list args)) - (handler-case (values (multiple-value-list (apply (cross function) args)) t) + (handler-case (apply (cross function) args) + ((or floating-point-overflow floating-point-inexact floating-point-underflow) + (c) + (values c nil t)) (error (condition) - (values condition nil)))) + (values condition nil)) + (:no-error (&rest results) + (let ((first (first results))) + (if (and (floatp first) + (float-infinity-p first)) + (values results nil t) + (values results t)))))) ;;; Variations of SPECIFIER-TYPE for parsing possibly wrong ;;; specifiers. diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 7d0eb5a6c..2c6fc2535 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -1022,65 +1022,3 @@ specify bindings for printer control variables.") (nreverse (mapcar #'car *compiler-print-variable-alist*)) (nreverse (mapcar #'cdr *compiler-print-variable-alist*)) ,@forms))) - -(defmacro make-defs (vars &body body) - (labels ((subst-if-with (test tree) - (labels ((s (subtree) - (multiple-value-bind (new replace) - (funcall test subtree) - (cond (replace new) - ((comma-p subtree) - (let ((new (s (comma-expr subtree)))) - (if (eq subtree new) - subtree - (unquote new (comma-kind subtree))))) - ((atom subtree) subtree) - (t (let ((car (s (car subtree))) - (cdr (s (cdr subtree)))) - (if (and (eq car (car subtree)) - (eq cdr (cdr subtree))) - subtree - (cond ((and (typep car '(cons symbol)) - (string= (car car) "$WHEN")) - (if (eval (second car)) - (append (cddr car) cdr) - cdr)) - ((and (typep car '(cons symbol)) - (string= (car car) "$UNLESS")) - (if (eval (second car)) - cdr - (append (cddr car) cdr))) - ((and (typep car '(cons symbol)) - (string= (car car) "$IF")) - (cons - (if (eval (second car)) - (third car) - (fourth car)) - cdr)) - (t - (cons car cdr)))))))))) - (s tree))) - (test (pattern with) - (lambda (x) - (when (symbolp x) - (let* ((str (string x)) - (start (search pattern str))) - (when start - (if (equal str pattern) - (values with t) - (values (symbolicate (subseq str 0 start) - with - (subseq str (+ start (length pattern)))) - t))))))) - (gen (vars body) - (if vars - (loop for with in (cdar vars) - append - (gen (cdr vars) - (let ((body body)) - (loop for v in (ensure-list (caar vars)) - for w in (ensure-list with) - do (setf body (subst-if-with (test (string v) w) body))) - body))) - body))) - `(progn ,@(gen vars body)))) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 909d18a13..fcd9e78a5 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -6024,16 +6024,10 @@ ((5.0f-9) #C(-4.123312f37 -0.0)))) (with-test (:name :reducing-constants.2) - (let* ((style-warning-p nil) - (fun (checked-compile `(lambda () (* 1.0 2 (expt 2 127))) - :allow-style-warnings t - :condition-transform (lambda (x) - (when (typep x 'style-warning) - (setf style-warning-p t)) - x)))) + (let* ((fun (checked-compile `(lambda () (* 1.0 2 (expt 2 127)))))) (handler-case (funcall fun) - (floating-point-overflow () (assert style-warning-p)) - (:no-error (x) (assert (not style-warning-p)) (assert (eql x sb-ext:single-float-positive-infinity)))))) + (floating-point-overflow ()) + (:no-error (x) (assert (eql x sb-ext:single-float-positive-infinity)))))) (with-test (:name (logbitp :past fixnum)) (checked-compile-and-assert () diff --git a/tests/float-2.pure.lisp b/tests/float-2.pure.lisp index 596c21ee2..ac81e45e8 100644 --- a/tests/float-2.pure.lisp +++ b/tests/float-2.pure.lisp @@ -852,3 +852,7 @@ fractional bits." (when (typep ratio 'ratio) (check-ratio-to-float ratio 1f0) (check-ratio-to-float ratio 1d0)))))) + +(with-test (:name :scale-float-rounding) + (assert (= (integer-decode-float (scale-float (opaque-identity 0.7836354097202904d0) -1032)) + (opaque-identity 3446464979698))))