From cfc0ec1bf1769f2e1899687b88e5af965d36bf14 Mon Sep 17 00:00:00 2001 From: toy <toy> Date: Mon, 25 Feb 2002 16:23:11 +0000 Subject: [PATCH] Make FTRUNCATE faster and less consy by manipulating the bits directly instead of calling the generic TRUNCATE. Make FFLOOR, FCEILING, and FROUND use FTRUNCATE so they benefit too. --- code/float.lisp | 116 ++++++++++++++++++++++++++++++++++++++- code/numbers.lisp | 86 ++++++++++++++++++++++++----- compiler/float-tran.lisp | 38 ++++++++++++- 3 files changed, 222 insertions(+), 18 deletions(-) diff --git a/code/float.lisp b/code/float.lisp index 5780aa862..5d2c2cf83 100644 --- a/code/float.lisp +++ b/code/float.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.24 2001/06/17 19:08:35 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.25 2002/02/25 16:23:10 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -17,7 +17,8 @@ ;;; Long-float support by Douglas Crosher, 1998. ;;; (in-package "KERNEL") -(export '(%unary-truncate %unary-round)) +(export '(%unary-truncate %unary-round %unary-ftruncate + %unary-ftruncate/single-float %unary-ftruncate/double-float)) (in-package "LISP") (export '(least-positive-normalized-short-float @@ -1061,6 +1062,117 @@ rounding modes & do ieee round-to-integer. (if (minusp number) (- rounded) rounded))))))) + +;; %UNARY-FTRUNCATE/SINGLE-FLOAT +;; +;; Basically the same as ftruncate, but specialized to handle only +;; single-floats and to only return the first value. We diddle the +;; bits directly to truncate the number to reduce consing. +(defun %unary-ftruncate/single-float (x) + (declare (single-float x) + (optimize (speed 3) (safety 0))) + (let* ((bits (kernel:single-float-bits x)) + (exp (ldb vm:single-float-exponent-byte bits)) + (biased (truly-the kernel:single-float-exponent + (- exp vm:single-float-bias)))) + (cond ((= exp vm:single-float-normal-exponent-max) + ;; Infinity or NaN. + x) + (t + ;; At this point, we have the number represented as + ;; + ;; x = sign * 2^exp * frac + ;; + ;; where 0.5 <= frac < 1.0 + ;; + ;; So if the exp <= 0, |x| < 1 and we know the result is 0. + ;; + ;; If exp >= (float-digits x), we know that all of the bits + ;; in the fraction are integer bits, so the result is x. + ;; + ;; For everything else, some of the bits in frac are + ;; fractional. Figure which ones they are and set them to + ;; zero. + (cond ((<= biased 0) + ;; Number is less than 1 + 0f0) + ((>= biased (float-digits x)) + ;; Number is an integer + x) + (t + ;; Somewhere in between. Zap the bits that + ;; represent the fraction part. + (let ((frac-bits (- (float-digits x) biased))) + (declare (type (signed-byte 32) bits)) + (setf bits (logandc2 bits (- (ash 1 frac-bits) 1))) + (kernel:make-single-float bits)))))))) + +;; %UNARY-FTRUNCATE/DOUBLE-FLOAT +;; +;; Like %UNARY-FTRUNCATE/SINGLE-FLOAT, except for double-float. + +(defun %unary-ftruncate/double-float (x) + (declare (double-float x) + (optimize (speed 3) (safety 0))) + (let* ((hi (kernel:double-float-high-bits x)) + (lo (kernel:double-float-low-bits x)) + (exp (ldb vm:double-float-exponent-byte hi)) + (biased (truly-the kernel:double-float-exponent + (- exp vm:double-float-bias)))) + (declare (type (signed-byte 32) hi) + (type (unsigned-byte 32) lo)) + (cond ((= exp vm:double-float-normal-exponent-max) + x) + ((< biased 0) + ;; Number is less than 1 + 0d0) + ((>= biased (float-digits x)) + ;; Number is an integer + x) + (t + ;; Somewhere in between. Zap the bits that + ;; represent the fraction part. + (let ((frac-bits (- (float-digits x) biased))) + (cond ((< frac-bits 32) + (setf lo (logandc2 lo (- (ash 1 frac-bits) 1)))) + (t + (setf lo 0) + (setf hi (logandc2 hi (- (ash 1 (- frac-bits 32)) 1))))) + (kernel:make-double-float hi lo)))))) + + +;;; %UNARY-FTRUNCATE -- Interface +;;; +;;; This function is called when we are doing an ftruncate without any +;;; funky divisor. Note that we do *not* return the second value of +;;; truncate, so it must be computed by the caller if needed. +;;; +;;; In the float case, we pick off small arguments so that compiler +;;; can use special-case operations. We use an exclusive test, since +;;; (due to round-off error), (float most-positive-signed-byte-32) may +;;; be greater than most-positive-signed-byte-32. We chose this +;;; because %unary-truncate can be optimized when the result is known +;;; to be a (signed-byte 32). +;;; +(defun %unary-ftruncate (number) + (macrolet ((truncate-float (rtype helper) + `(if (< (float (- (- (ash 1 31)) 1) number) + number + (float (ash 1 31) number)) + (coerce (truly-the (signed-byte 32) + (%unary-truncate number)) + ',rtype) + (,helper number)))) + (number-dispatch ((number real)) + ((integer) + (float number)) + ((ratio) + (float (truncate (numerator number) (denominator number)))) + ((single-float) + (truncate-float single-float %unary-ftruncate/single-float)) + ((double-float) + (truncate-float double-float %unary-ftruncate/double-float))))) + (defun rational (x) diff --git a/code/numbers.lisp b/code/numbers.lisp index 8d12b688e..c747d57ec 100644 --- a/code/numbers.lisp +++ b/code/numbers.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.39 2001/09/28 14:56:28 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.40 2002/02/25 16:23:10 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -669,7 +669,9 @@ ;;; maybe-inline for now, so that the power-of-2 ceiling and floor transforms ;;; get a chance. ;;; -(declaim (inline rem mod fceiling ffloor ftruncate)) +;;; Don't inline ftruncate because it's probably too big now. +;;; +(declaim (inline rem mod fceiling ffloor)) (declaim (maybe-inline ceiling floor)) ;;; If the numbers do not divide exactly and the result of (/ number divisor) @@ -742,20 +744,74 @@ rem))) -(macrolet ((frob (name op doc) - `(defun ,name (number &optional (divisor 1)) - ,doc - (multiple-value-bind (res rem) (,op number divisor) - (values (float res (if (floatp rem) rem 1.0)) rem))))) - (frob ffloor floor - "Same as FLOOR, but returns first value as a float.") - (frob fceiling ceiling - "Same as CEILING, but returns first value as a float." ) - (frob ftruncate truncate - "Same as TRUNCATE, but returns first value as a float.") - (frob fround round - "Same as ROUND, but returns first value as a float.")) +(defun ftruncate (number &optional (divisor 1)) + "Same as TRUNCATE, but returns first value as a float." + (macrolet ((truncate-float (rtype) + `(let* ((float-div (coerce divisor ',rtype)) + (res (%unary-ftruncate (/ number float-div)))) + (values res + (- number + (* (coerce res ',rtype) float-div)))))) + (number-dispatch ((number real) (divisor real)) + (((foreach fixnum bignum ratio) (or fixnum bignum ratio)) + (multiple-value-bind (q r) + (truncate number divisor) + (values (float q) r))) + (((foreach single-float double-float) + (or rational single-float)) + (if (eql divisor 1) + (let ((res (%unary-ftruncate number))) + (values res (- number (coerce res '(dispatch-type number))))) + (truncate-float (dispatch-type number)))) + ((double-float (or single-float double-float)) + (truncate-float double-float)) + ((single-float double-float) + (truncate-float double-float)) + (((foreach fixnum bignum ratio) + (foreach single-float double-float)) + (truncate-float (dispatch-type divisor)))))) + +(defun ffloor (number &optional (divisor 1)) + "Same as FLOOR, but returns first value as a float." + (multiple-value-bind (tru rem) (ftruncate number divisor) + (if (and (not (zerop rem)) + (if (minusp divisor) + (plusp number) + (minusp number))) + (values (1- tru) (+ rem divisor)) + (values tru rem)))) + +(defun fceiling (number &optional (divisor 1)) + "Same as CEILING, but returns first value as a float." + (multiple-value-bind (tru rem) (ftruncate number divisor) + (if (and (not (zerop rem)) + (if (minusp divisor) + (minusp number) + (plusp number))) + (values (+ tru 1) (- rem divisor)) + (values tru rem)))) + + +(defun fround (number &optional (divisor 1)) + "Same as ROUND, but returns first value as a float." + (if (eql divisor 1) + (round number) + (multiple-value-bind (tru rem) + (ftruncate number divisor) + (let ((thresh (/ (abs divisor) 2))) + (cond ((or (> rem thresh) + (and (= rem thresh) (oddp tru))) + (if (minusp divisor) + (values (- tru 1) (+ rem divisor)) + (values (+ tru 1) (- rem divisor)))) + ((let ((-thresh (- thresh))) + (or (< rem -thresh) + (and (= rem -thresh) (oddp tru)))) + (if (minusp divisor) + (values (+ tru 1) (- rem divisor)) + (values (- tru 1) (+ rem divisor)))) + (t (values tru rem))))))) ;;;; Comparisons: diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp index 8d3342777..901f4171a 100644 --- a/compiler/float-tran.lisp +++ b/compiler/float-tran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.84 2001/09/24 15:25:38 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.85 2002/02/25 16:23:11 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -92,6 +92,42 @@ (values (1+ tru) (- rem divisor)) (values tru rem)))) +(defknown %unary-ftruncate/single-float (single-float) single-float + (movable foldable flushable)) +(defknown %unary-ftruncate/double-float (double-float) double-float + (movable foldable flushable)) + +(defknown %unary-ftruncate (float) float + (movable foldable flushable)) + +;; Convert (ftruncate x y) to the obvious implementation. We only +;; want this under certain conditions and let the generic ftruncate +;; handle the rest. (Note: if y = 1, the divide and multiply by y +;; should be removed by other deftransforms.) + +(deftransform ftruncate ((x &optional (y 1)) + (float &optional (or float integer))) + '(let ((res (%unary-ftruncate (/ x y)))) + (values res (- x (* y res))))) + +;; Convert %unary-ftruncate to unary-ftruncate/{single,double}-float +;; if x is known to be of the right type. Also, if the result is +;; known to fit in the same range as a (signed-byte 32), convert this +;; to %unary-truncate, which might be a single instruction, and float +;; the result. + +(macrolet ((frob (ftype func) + `(deftransform %unary-ftruncate ((x) (,ftype)) + (let* ((x-type (continuation-type x)) + (lo (numeric-type-low x-type)) + (hi (numeric-type-high x-type))) + (if (and (numberp lo) (numberp hi) + (< (- (ash 1 31)) lo) + (< hi (ash 1 31))) + '(coerce (%unary-truncate x) ',ftype) + '(,func x)))))) + (frob single-float %unary-ftruncate/single-float) + (frob double-float %unary-ftruncate/double-float)) ;;; Random: ;;; -- GitLab