Fix scale-float rounding for subnormals

Shifting right discards some set bits. Rely on the FPU multiplication
instead.

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.
+;;; ====================================================

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)

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)

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.
+;; Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved.
-(defun scale-single-float (x exp)
+;;
-  (declare (single-float x) (integer exp))
+;; Developed at SunPro, a Sun Microsystems, Inc. business.
-  (etypecase exp
+;; Permission to use, copy, modify, and distribute this
-    (fixnum
+;; software is freely granted, provided that this notice
-     (let* ((bits (single-float-bits x))
+;; is preserved.
-            (old-exp (ldb sb-vm:single-float-exponent-byte bits))
+;; ====================================================
-            (new-exp (+ old-exp exp)))
+(make-defs ((($type $make $tiny $huge $two^ $two^- $size)
-       (cond
+             (single-float make-single-float
-         ((zerop x) x)
+                           1f-30 1f30 3.355443200f7 2.9802322388f-8 31)
-         ((or (< old-exp sb-vm:single-float-normal-exponent-min)
+             #+64-bit
-              (< new-exp sb-vm:single-float-normal-exponent-min))
+             (double-float %make-double-float
-          (scale-single-float-maybe-underflow x exp))
+                           1d-300 1d300 1.80143985094819840000d16 5.55111512312578270212d-17 63)))
-         ((or (> old-exp sb-vm:single-float-normal-exponent-max)
+  (defun scale-$type (float n)
-              (> new-exp sb-vm:single-float-normal-exponent-max))
+    (declare ($type float)
-          (scale-single-float-maybe-overflow x exp))
+             (integer n)
-         (t
+             (optimize speed))
-          (make-single-float (dpb new-exp
+    (block scale-$type
-                                  sb-vm:single-float-exponent-byte
+      (let* ((1+digits (1+ sb-vm\:$type-digits))
-                                  bits))))))
+             (two^digits $two^)
-    (unsigned-byte (scale-single-float-maybe-overflow x exp))
+             (two^-digits $two^-)
-    ((integer * 0) (scale-single-float-maybe-underflow x exp))))
+             (tiny $tiny)
+             (huge $huge)
+             (bits ($type-bits float))
+             (exp (ldb sb-vm\:$type-exponent-byte bits)))
 
-(defun scale-double-float (x exp)
+        ;; 0 or subnormal x
-  (etypecase exp
+        (when (zerop exp)
-    (fixnum
+          (when (zerop (ldb (byte $size 0) bits))
-     #+64-bit
+            ;; +-0
-     (let* ((bits (double-float-bits x))
+            (return-from scale-$type float))
-            (old-exp (ldb sb-vm:double-float-exponent-byte bits))
+
-            (new-exp (+ old-exp exp)))
+          (setf float (sb-xc:* float two^digits)
-       (cond
+                bits ($type-bits float)
-         ((zerop x) x)
+                exp (- (ldb sb-vm\:$type-exponent-byte bits)
-         ((or (< old-exp sb-vm:double-float-normal-exponent-min)
+                       1+digits)))
-              (< new-exp sb-vm:double-float-normal-exponent-min))
+
-          (scale-double-float-maybe-underflow x exp))
+        ;; NaN or Inf
-         ((or (> old-exp sb-vm:double-float-normal-exponent-max)
+        (when (= exp (1+ sb-vm\:$type-normal-exponent-max))
-              (> new-exp sb-vm:double-float-normal-exponent-max))
+          (return-from scale-$type (sb-xc:+ float float)))
-          (scale-double-float-maybe-overflow x exp))
+
+        (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)))))
+          (sb-xc:*
-     #-64-bit
+           (make-double-float
-     (let* ((hi (double-float-high-bits x))
+            (dpb (+ exp-new 1+digits) sb-vm:double-float-hi-exponent-byte
-            (lo (double-float-low-bits x))
+                 hi-bits)
-            (old-exp (ldb sb-vm:double-float-hi-exponent-byte hi))
+            lo-bits)
-            (new-exp (+ old-exp exp)))
+           two^-digits)))))))
-       (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))))
 
 ;;; Dispatch to the correct type-specific scale-float function.
 (defun scale-float (f ex)

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.
 ;;;

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

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))

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.

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))))

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)
+  (let* ((fun (checked-compile `(lambda () (* 1.0 2 (expt 2 127))))))
-         (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))))
     (handler-case (funcall fun)
-      (floating-point-overflow () (assert style-warning-p))
+      (floating-point-overflow ())
-      (:no-error (x) (assert (not style-warning-p)) (assert (eql x sb-ext:single-float-positive-infinity))))))
+      (:no-error (x) (assert (eql x sb-ext:single-float-positive-infinity))))))
 
 (with-test (:name (logbitp :past fixnum))
   (checked-compile-and-assert ()

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))))