From 60beb67fb92c33a934ad7710692d779760bcc39a Mon Sep 17 00:00:00 2001 From: Juho Snellman Date: Fri, 11 Feb 2005 07:32:33 +0000 Subject: [PATCH] 0.8.19.23: Optimize float/fixnum comparisons, primarily for the benefit of McCLIM. If the fixnum's value is in a range where it's guaranteed to have an exact float representation, coerce it to a float and do a float comparison. Otherwise fall back to the old behaviour of rationalizing the float. --- NEWS | 2 ++ src/code/numbers.lisp | 43 +++++++++++++++++++++++++++++++++++++++++++ tests/arith.pure.lisp | 34 ++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 80 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index e3ea60c..d105bd7 100644 --- a/NEWS +++ b/NEWS @@ -17,6 +17,8 @@ changes in sbcl-0.8.20 (0.9alpha.0?) relative to sbcl-0.8.19: CLOS classes has had redundant type checks removed. * optimization: added declarations to speed up operations that access the internal character database (for example STRING-UPCASE) + * optimization: comparison operations between floats and sufficiently small + fixnums no longer create extra rationals * fixed some bugs related to Unicode integration: ** portions of multibyte characters at the end of buffers for character-based file input are correctly transferred to the diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index c0440f3..2b26643 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -819,6 +819,15 @@ the first." (declare (type real number result)) (if (< (car nlist) result) (setq result (car nlist))))) +(defconstant most-positive-exactly-single-float-fixnum + (min #xffffff most-positive-fixnum)) +(defconstant most-negative-exactly-single-float-fixnum + (max #x-ffffff most-negative-fixnum)) +(defconstant most-positive-exactly-double-float-fixnum + (min #x1fffffffffffff most-positive-fixnum)) +(defconstant most-negative-exactly-double-float-fixnum + (max #x-1fffffffffffff most-negative-fixnum)) + (eval-when (:compile-toplevel :execute) ;;; The INFINITE-X-FINITE-Y and INFINITE-Y-FINITE-X args tell us how @@ -838,6 +847,40 @@ the first." #!+long-float ((long-float (foreach single-float double-float)) (,op x (coerce y 'long-float))) + ((fixnum (foreach single-float double-float)) + (if (float-infinity-p y) + ,infinite-y-finite-x + ;; If the fixnum has an exact float representation, do a + ;; float comparison. Otherwise do the slow float -> ratio + ;; conversion. + (multiple-value-bind (lo hi) + (case '(dispatch-type y) + ('single-float + (values most-negative-exactly-single-float-fixnum + most-positive-exactly-single-float-fixnum)) + ('double-float + (values most-negative-exactly-double-float-fixnum + most-positive-exactly-double-float-fixnum))) + (if (<= lo y hi) + (,op (coerce x '(dispatch-type y)) y) + (,op x (rational y)))))) + (((foreach single-float double-float) fixnum) + (if (eql y 0) + (,op x (coerce 0 '(dispatch-type x))) + (if (float-infinity-p x) + ,infinite-x-finite-y + ;; Likewise + (multiple-value-bind (lo hi) + (case '(dispatch-type x) + ('single-float + (values most-negative-exactly-single-float-fixnum + most-positive-exactly-single-float-fixnum)) + ('double-float + (values most-negative-exactly-double-float-fixnum + most-positive-exactly-double-float-fixnum))) + (if (<= lo y hi) + (,op x (coerce y '(dispatch-type x))) + (,op (rational x) y)))))) (((foreach single-float double-float) double-float) (,op (coerce x 'double-float) y)) ((double-float single-float) diff --git a/tests/arith.pure.lisp b/tests/arith.pure.lisp index 2b1266d..25981fc 100644 --- a/tests/arith.pure.lisp +++ b/tests/arith.pure.lisp @@ -224,3 +224,37 @@ (frob /) (frob floor) (frob ceiling)) + +;; Check that the logic in SB-KERNEL::BASIC-COMPARE for doing fixnum/float +;; comparisons without rationalizing the floats still gives the right anwers +;; in the edge cases (had a fencepost error). +(macrolet ((test (range type sign) + `(let (ints + floats + (start (- ,(find-symbol (format nil + "MOST-~A-EXACTLY-~A-FIXNUM" + sign type) + :sb-kernel) + ,range))) + (dotimes (i (1+ (* ,range 2))) + (let* ((x (+ start i)) + (y (coerce x ',type))) + (push x ints) + (push y floats))) + (dolist (i ints) + (dolist (f floats) + (dolist (op '(< <= = >= >)) + (unless (eq (funcall op i f) + (funcall op i (rationalize f))) + (error "(not (eq (~a ~a ~f) (~a ~a ~a)))~%" + op i f + op i (rationalize f))) + (unless (eq (funcall op f i) + (funcall op (rationalize f) i)) + (error "(not (eq (~a ~f ~a) (~a ~a ~a)))~%" + op f i + op (rationalize f) i)))))))) + (test 32 double-float negative) + (test 32 double-float positive) + (test 32 single-float negative) + (test 32 single-float positive)) diff --git a/version.lisp-expr b/version.lisp-expr index 1c85a50..c55cc11 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.19.22" +"0.8.19.23" -- 1.7.10.4