X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffloat.lisp;h=a3a0114a7f752f74f4a94239572b150d64baef9a;hb=b14a61c6af3e3005c94e633e727177346240066e;hp=a8dd5f0f218633d26a0b25fe6c18eade83cd32ce;hpb=9dcd91eba92f6f2db9ae65d7640f2cd2f4ee2a8b;p=sbcl.git diff --git a/src/code/float.lisp b/src/code/float.lisp index a8dd5f0..a3a0114 100644 --- a/src/code/float.lisp +++ b/src/code/float.lisp @@ -170,7 +170,7 @@ (defun float-radix (x) #!+sb-doc "Return (as an integer) the radix b of its floating-point argument." - (declare (ignore x)) + (declare (ignore x) (type float x)) 2) ;;;; INTEGER-DECODE-FLOAT and DECODE-FLOAT @@ -630,7 +630,7 @@ (frob %long-float long-float)) ;;; Convert a ratio to a float. We avoid any rounding error by doing an -;;; integer division. Accuracy is important to preserve read/print +;;; integer division. Accuracy is important to preserve print-read ;;; consistency, since this is ultimately how the reader reads a float. We ;;; scale the numerator by a power of two until the division results in the ;;; desired number of fraction bits, then do round-to-nearest. @@ -695,70 +695,71 @@ (setq shifted-num (ash shifted-num -1)) (incf scale))))))) -#| -These might be useful if we ever have a machine without float/integer -conversion hardware. For now, we'll use special ops that -uninterruptibly frob the rounding modes & do ieee round-to-integer. - -;;; The compiler compiles a call to this when we are doing %UNARY-TRUNCATE -;;; and the result is known to be a fixnum. We can avoid some generic -;;; arithmetic in this case. -(defun %unary-truncate-single-float/fixnum (x) - (declare (single-float x) (values fixnum)) - (locally (declare (optimize (speed 3) (safety 0))) - (let* ((bits (single-float-bits x)) - (exp (ldb sb!vm:single-float-exponent-byte bits)) - (frac (logior (ldb sb!vm:single-float-significand-byte bits) - sb!vm:single-float-hidden-bit)) - (shift (- exp sb!vm:single-float-digits sb!vm:single-float-bias))) - (when (> exp sb!vm:single-float-normal-exponent-max) - (error 'floating-point-invalid-operation :operator 'truncate - :operands (list x))) - (if (<= shift (- sb!vm:single-float-digits)) - 0 - (let ((res (ash frac shift))) - (declare (type (unsigned-byte 31) res)) - (if (minusp bits) - (- res) - res)))))) - -;;; Double-float version of this operation (see above single op). -(defun %unary-truncate-double-float/fixnum (x) - (declare (double-float x) (values fixnum)) - (locally (declare (optimize (speed 3) (safety 0))) - (let* ((hi-bits (double-float-high-bits x)) - (exp (ldb sb!vm:double-float-exponent-byte hi-bits)) - (frac (logior (ldb sb!vm:double-float-significand-byte hi-bits) - sb!vm:double-float-hidden-bit)) - (shift (- exp (- sb!vm:double-float-digits sb!vm:n-word-bits) - sb!vm:double-float-bias))) - (when (> exp sb!vm:double-float-normal-exponent-max) - (error 'floating-point-invalid-operation :operator 'truncate - :operands (list x))) - (if (<= shift (- sb!vm:n-word-bits sb!vm:double-float-digits)) - 0 - (let* ((res-hi (ash frac shift)) - (res (if (plusp shift) - (logior res-hi - (the fixnum - (ash (double-float-low-bits x) - (- shift sb!vm:n-word-bits)))) - res-hi))) - (declare (type (unsigned-byte 31) res-hi res)) - (if (minusp hi-bits) - (- res) - res)))))) -|# +;;; These might be useful if we ever have a machine without float/integer +;;; conversion hardware. For now, we'll use special ops that +;;; uninterruptibly frob the rounding modes & do ieee round-to-integer. +#+nil +(progn + ;; The compiler compiles a call to this when we are doing %UNARY-TRUNCATE + ;; and the result is known to be a fixnum. We can avoid some generic + ;; arithmetic in this case. + (defun %unary-truncate-single-float/fixnum (x) + (declare (single-float x) (values fixnum)) + (locally (declare (optimize (speed 3) (safety 0))) + (let* ((bits (single-float-bits x)) + (exp (ldb sb!vm:single-float-exponent-byte bits)) + (frac (logior (ldb sb!vm:single-float-significand-byte bits) + sb!vm:single-float-hidden-bit)) + (shift (- exp sb!vm:single-float-digits sb!vm:single-float-bias))) + (when (> exp sb!vm:single-float-normal-exponent-max) + (error 'floating-point-invalid-operation :operator 'truncate + :operands (list x))) + (if (<= shift (- sb!vm:single-float-digits)) + 0 + (let ((res (ash frac shift))) + (declare (type (unsigned-byte 31) res)) + (if (minusp bits) + (- res) + res)))))) + ;; Double-float version of this operation (see above single op). + (defun %unary-truncate-double-float/fixnum (x) + (declare (double-float x) (values fixnum)) + (locally (declare (optimize (speed 3) (safety 0))) + (let* ((hi-bits (double-float-high-bits x)) + (exp (ldb sb!vm:double-float-exponent-byte hi-bits)) + (frac (logior (ldb sb!vm:double-float-significand-byte hi-bits) + sb!vm:double-float-hidden-bit)) + (shift (- exp (- sb!vm:double-float-digits sb!vm:n-word-bits) + sb!vm:double-float-bias))) + (when (> exp sb!vm:double-float-normal-exponent-max) + (error 'floating-point-invalid-operation :operator 'truncate + :operands (list x))) + (if (<= shift (- sb!vm:n-word-bits sb!vm:double-float-digits)) + 0 + (let* ((res-hi (ash frac shift)) + (res (if (plusp shift) + (logior res-hi + (the fixnum + (ash (double-float-low-bits x) + (- shift sb!vm:n-word-bits)))) + res-hi))) + (declare (type (unsigned-byte 31) res-hi res)) + (if (minusp hi-bits) + (- res) + res))))))) ;;; This function is called when we are doing a truncate without any funky ;;; divisor, i.e. converting a float or ratio to an integer. 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-fixnum) may be greater than -;;; most-positive-fixnum. +;;; 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-fixnum) is likely +;;; to be equal to (1+ most-positive-fixnum). An exclusive test is +;;; good enough, because most-positive-fixnum will be one less than a +;;; power of two, and that power of two will be exactly representable +;;; as a float (at least until we get 128-bit fixnums). (defun %unary-truncate (number) (number-dispatch ((number real)) ((integer) number) @@ -774,6 +775,24 @@ uninterruptibly frob the rounding modes & do ieee round-to-integer. (- res) res))))))) +;;; Specialized versions for floats. +(macrolet ((def (type name) + `(defun ,name (number) + (if (< ,(coerce sb!xc:most-negative-fixnum type) + number + ,(coerce sb!xc:most-positive-fixnum type)) + (truly-the fixnum (,name number)) + ;; General -- slow -- case. + (multiple-value-bind (bits exp) (integer-decode-float number) + (let ((res (ash bits exp))) + (if (minusp number) + (- res) + res))))))) + (def single-float %unary-truncate/single-float) + (def double-float %unary-truncate/double-float) + #!+long-float + (def double-float %unary-truncate/long-float)) + ;;; Similar to %UNARY-TRUNCATE, but rounds to the nearest integer. If we ;;; can't use the round primitive, then we do our own round-to-nearest on the ;;; result of i-d-f. [Note that this rounding will really only happen with @@ -791,12 +810,13 @@ uninterruptibly frob the rounding modes & do ieee round-to-integer. (truly-the fixnum (%unary-round number)) (multiple-value-bind (bits exp) (integer-decode-float number) (let* ((shifted (ash bits exp)) - (rounded (if (and (minusp exp) - (oddp shifted) - (eql (logand bits - (lognot (ash -1 (- exp)))) - (ash 1 (- -1 exp)))) - (1+ shifted) + (rounded (if (minusp exp) + (let ((fractional-bits (logand bits (lognot (ash -1 (- exp))))) + (0.5bits (ash 1 (- -1 exp)))) + (cond + ((> fractional-bits 0.5bits) (1+ shifted)) + ((< fractional-bits 0.5bits) shifted) + (t (if (oddp shifted) (1+ shifted) shifted)))) shifted))) (if (minusp number) (- rounded)