X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffloat.lisp;h=d5ea0b9c0dee95aa7de75cbf224469767418f150;hb=01044af1b8d69fc3899dc0417064c1512223223d;hp=2d0650f29f51b98e1003a30c669642edcc9e5d62;hpb=e37366e7bb72bc80c6c9908efe09f94ce26add16;p=sbcl.git diff --git a/src/code/float.lisp b/src/code/float.lisp index 2d0650f..d5ea0b9 100644 --- a/src/code/float.lisp +++ b/src/code/float.lisp @@ -1,7 +1,7 @@ -;;;; This file contains the definitions of float specific number +;;;; This file contains the definitions of float-specific number ;;;; support (other than irrational stuff, which is in irrat.) There is ;;;; code in here that assumes there are only two float formats: IEEE -;;;; single and double. (Long-float support has been added, but bugs +;;;; single and double. (LONG-FLOAT support has been added, but bugs ;;;; may still remain due to old code which assumes this dichotomy.) ;;;; This software is part of the SBCL system. See the README file for @@ -15,161 +15,6 @@ (in-package "SB!KERNEL") -;;;; utilities - -(eval-when (:compile-toplevel :load-toplevel :execute) - -;;; These functions let us create floats from bits with the significand -;;; uniformly represented as an integer. This is less efficient for double -;;; floats, but is more convenient when making special values, etc. -(defun single-from-bits (sign exp sig) - (declare (type bit sign) (type (unsigned-byte 24) sig) - (type (unsigned-byte 8) exp)) - (make-single-float - (dpb exp sb!vm:single-float-exponent-byte - (dpb sig sb!vm:single-float-significand-byte - (if (zerop sign) 0 -1))))) -(defun double-from-bits (sign exp sig) - (declare (type bit sign) (type (unsigned-byte 53) sig) - (type (unsigned-byte 11) exp)) - (make-double-float (dpb exp sb!vm:double-float-exponent-byte - (dpb (ash sig -32) sb!vm:double-float-significand-byte - (if (zerop sign) 0 -1))) - (ldb (byte 32 0) sig))) -#!+(and long-float x86) -(defun long-from-bits (sign exp sig) - (declare (type bit sign) (type (unsigned-byte 64) sig) - (type (unsigned-byte 15) exp)) - (make-long-float (logior (ash sign 15) exp) - (ldb (byte 32 32) sig) - (ldb (byte 32 0) sig))) - -) ; EVAL-WHEN - -;;;; float parameters - -(defconstant least-positive-single-float (single-from-bits 0 0 1)) -(defconstant least-positive-short-float least-positive-single-float) -(defconstant least-negative-single-float (single-from-bits 1 0 1)) -(defconstant least-negative-short-float least-negative-single-float) -(defconstant least-positive-double-float (double-from-bits 0 0 1)) -#!-long-float -(defconstant least-positive-long-float least-positive-double-float) -#!+(and long-float x86) -(defconstant least-positive-long-float (long-from-bits 0 0 1)) -(defconstant least-negative-double-float (double-from-bits 1 0 1)) -#!-long-float -(defconstant least-negative-long-float least-negative-double-float) -#!+(and long-float x86) -(defconstant least-negative-long-float (long-from-bits 1 0 1)) - -(defconstant least-positive-normalized-single-float - (single-from-bits 0 sb!vm:single-float-normal-exponent-min 0)) -(defconstant least-positive-normalized-short-float - least-positive-normalized-single-float) -(defconstant least-negative-normalized-single-float - (single-from-bits 1 sb!vm:single-float-normal-exponent-min 0)) -(defconstant least-negative-normalized-short-float - least-negative-normalized-single-float) -(defconstant least-positive-normalized-double-float - (double-from-bits 0 sb!vm:double-float-normal-exponent-min 0)) -#!-long-float -(defconstant least-positive-normalized-long-float - least-positive-normalized-double-float) -#!+(and long-float x86) -(defconstant least-positive-normalized-long-float - (long-from-bits 0 sb!vm:long-float-normal-exponent-min - (ash sb!vm:long-float-hidden-bit 32))) -(defconstant least-negative-normalized-double-float - (double-from-bits 1 sb!vm:double-float-normal-exponent-min 0)) -#!-long-float -(defconstant least-negative-normalized-long-float - least-negative-normalized-double-float) -#!+(and long-float x86) -(defconstant least-negative-normalized-long-float - (long-from-bits 1 sb!vm:long-float-normal-exponent-min - (ash sb!vm:long-float-hidden-bit 32))) - -(defconstant most-positive-single-float - (single-from-bits 0 sb!vm:single-float-normal-exponent-max - (ldb sb!vm:single-float-significand-byte -1))) -(defconstant most-positive-short-float most-positive-single-float) -(defconstant most-negative-single-float - (single-from-bits 1 sb!vm:single-float-normal-exponent-max - (ldb sb!vm:single-float-significand-byte -1))) -(defconstant most-negative-short-float most-negative-single-float) -(defconstant most-positive-double-float - (double-from-bits 0 sb!vm:double-float-normal-exponent-max - (ldb (byte sb!vm:double-float-digits 0) -1))) -#!-long-float -(defconstant most-positive-long-float most-positive-double-float) -#!+(and long-float x86) -(defconstant most-positive-long-float - (long-from-bits 0 sb!vm:long-float-normal-exponent-max - (ldb (byte sb!vm:long-float-digits 0) -1))) -(defconstant most-negative-double-float - (double-from-bits 1 sb!vm:double-float-normal-exponent-max - (ldb (byte sb!vm:double-float-digits 0) -1))) -#!-long-float -(defconstant most-negative-long-float most-negative-double-float) -#!+(and long-float x86) -(defconstant most-negative-long-float - (long-from-bits 1 sb!vm:long-float-normal-exponent-max - (ldb (byte sb!vm:long-float-digits 0) -1))) - -;;; We don't want to do these DEFCONSTANTs at cross-compilation time, -;;; because the cross-compilation host might not support floating -;;; point infinities. -(eval-when (:load-toplevel :execute) -(defconstant single-float-positive-infinity - (single-from-bits 0 (1+ sb!vm:single-float-normal-exponent-max) 0)) -(defconstant short-float-positive-infinity single-float-positive-infinity) -(defconstant single-float-negative-infinity - (single-from-bits 1 (1+ sb!vm:single-float-normal-exponent-max) 0)) -(defconstant short-float-negative-infinity single-float-negative-infinity) -(defconstant double-float-positive-infinity - (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0)) -#!+(not long-float) -(defconstant long-float-positive-infinity double-float-positive-infinity) -#!+(and long-float x86) -(defconstant long-float-positive-infinity - (long-from-bits 0 (1+ sb!vm:long-float-normal-exponent-max) - (ash sb!vm:long-float-hidden-bit 32))) -(defconstant double-float-negative-infinity - (double-from-bits 1 (1+ sb!vm:double-float-normal-exponent-max) 0)) -#!+(not long-float) -(defconstant long-float-negative-infinity double-float-negative-infinity) -#!+(and long-float x86) -(defconstant long-float-negative-infinity - (long-from-bits 1 (1+ sb!vm:long-float-normal-exponent-max) - (ash sb!vm:long-float-hidden-bit 32))) -) ; EVAL-WHEN - -(defconstant single-float-epsilon - (single-from-bits 0 (- sb!vm:single-float-bias - (1- sb!vm:single-float-digits)) 1)) -(defconstant short-float-epsilon single-float-epsilon) -(defconstant single-float-negative-epsilon - (single-from-bits 0 (- sb!vm:single-float-bias sb!vm:single-float-digits) 1)) -(defconstant short-float-negative-epsilon single-float-negative-epsilon) -(defconstant double-float-epsilon - (double-from-bits 0 (- sb!vm:double-float-bias - (1- sb!vm:double-float-digits)) 1)) -#!-long-float -(defconstant long-float-epsilon double-float-epsilon) -#!+(and long-float x86) -(defconstant long-float-epsilon - (long-from-bits 0 (- sb!vm:long-float-bias (1- sb!vm:long-float-digits)) - (+ 1 (ash sb!vm:long-float-hidden-bit 32)))) -(defconstant double-float-negative-epsilon - (double-from-bits 0 (- sb!vm:double-float-bias sb!vm:double-float-digits) 1)) -#!-long-float -(defconstant long-float-negative-epsilon double-float-negative-epsilon) -#!+(and long-float x86) -(defconstant long-float-negative-epsilon - (long-from-bits 0 (- sb!vm:long-float-bias sb!vm:long-float-digits) - (+ 1 (ash sb!vm:long-float-hidden-bit 32)))) - ;;;; float predicates and environment query #!-sb-fluid @@ -192,59 +37,60 @@ (and (zerop (ldb sb!vm:long-float-exponent-byte (long-float-exp-bits x))) (not (zerop x)))))) -(macrolet ((def-frob (name doc single double #!+(and long-float x86) long) - `(defun ,name (x) - ,doc - (number-dispatch ((x float)) - ((single-float) - (let ((bits (single-float-bits x))) - (and (> (ldb sb!vm:single-float-exponent-byte bits) - sb!vm:single-float-normal-exponent-max) - ,single))) - ((double-float) - (let ((hi (double-float-high-bits x)) - (lo (double-float-low-bits x))) - (declare (ignorable lo)) - (and (> (ldb sb!vm:double-float-exponent-byte hi) - sb!vm:double-float-normal-exponent-max) - ,double))) - #!+(and long-float x86) - ((long-float) - (let ((exp (long-float-exp-bits x)) - (hi (long-float-high-bits x)) - (lo (long-float-low-bits x))) - (declare (ignorable lo)) - (and (> (ldb sb!vm:long-float-exponent-byte exp) - sb!vm:long-float-normal-exponent-max) - ,long))))))) - - (def-frob float-infinity-p - "Return true if the float X is an infinity (+ or -)." - (zerop (ldb sb!vm:single-float-significand-byte bits)) - (and (zerop (ldb sb!vm:double-float-significand-byte hi)) - (zerop lo)) - #!+(and long-float x86) - (and (zerop (ldb sb!vm:long-float-significand-byte hi)) - (zerop lo))) - - (def-frob float-nan-p - "Return true if the float X is a NaN (Not a Number)." - (not (zerop (ldb sb!vm:single-float-significand-byte bits))) - (or (not (zerop (ldb sb!vm:double-float-significand-byte hi))) - (not (zerop lo))) - #!+(and long-float x86) - (or (not (zerop (ldb sb!vm:long-float-significand-byte hi))) - (not (zerop lo)))) - - (def-frob float-trapping-nan-p - "Return true if the float X is a trapping NaN (Not a Number)." - (zerop (logand (ldb sb!vm:single-float-significand-byte bits) - sb!vm:single-float-trapping-nan-bit)) - (zerop (logand (ldb sb!vm:double-float-significand-byte hi) - sb!vm:double-float-trapping-nan-bit)) - #!+(and long-float x86) - (zerop (logand (ldb sb!vm:long-float-significand-byte hi) - sb!vm:long-float-trapping-nan-bit)))) +(defmacro !define-float-dispatching-function + (name doc single double #!+(and long-float x86) long) + `(defun ,name (x) + ,doc + (number-dispatch ((x float)) + ((single-float) + (let ((bits (single-float-bits x))) + (and (> (ldb sb!vm:single-float-exponent-byte bits) + sb!vm:single-float-normal-exponent-max) + ,single))) + ((double-float) + (let ((hi (double-float-high-bits x)) + (lo (double-float-low-bits x))) + (declare (ignorable lo)) + (and (> (ldb sb!vm:double-float-exponent-byte hi) + sb!vm:double-float-normal-exponent-max) + ,double))) + #!+(and long-float x86) + ((long-float) + (let ((exp (long-float-exp-bits x)) + (hi (long-float-high-bits x)) + (lo (long-float-low-bits x))) + (declare (ignorable lo)) + (and (> (ldb sb!vm:long-float-exponent-byte exp) + sb!vm:long-float-normal-exponent-max) + ,long)))))) + +(!define-float-dispatching-function float-infinity-p + "Return true if the float X is an infinity (+ or -)." + (zerop (ldb sb!vm:single-float-significand-byte bits)) + (and (zerop (ldb sb!vm:double-float-significand-byte hi)) + (zerop lo)) + #!+(and long-float x86) + (and (zerop (ldb sb!vm:long-float-significand-byte hi)) + (zerop lo))) + +(!define-float-dispatching-function float-nan-p + "Return true if the float X is a NaN (Not a Number)." + (not (zerop (ldb sb!vm:single-float-significand-byte bits))) + (or (not (zerop (ldb sb!vm:double-float-significand-byte hi))) + (not (zerop lo))) + #!+(and long-float x86) + (or (not (zerop (ldb sb!vm:long-float-significand-byte hi))) + (not (zerop lo)))) + +(!define-float-dispatching-function float-trapping-nan-p + "Return true if the float X is a trapping NaN (Not a Number)." + (zerop (logand (ldb sb!vm:single-float-significand-byte bits) + sb!vm:single-float-trapping-nan-bit)) + (zerop (logand (ldb sb!vm:double-float-significand-byte hi) + sb!vm:double-float-trapping-nan-bit)) + #!+(and long-float x86) + (zerop (logand (ldb sb!vm:long-float-significand-byte hi) + sb!vm:long-float-trapping-nan-bit))) ;;; If denormalized, use a subfunction from INTEGER-DECODE-FLOAT to find the ;;; actual exponent (and hence how denormalized it is), otherwise we just @@ -252,7 +98,7 @@ #!-sb-fluid (declaim (maybe-inline float-precision)) (defun float-precision (f) #!+sb-doc - "Returns a non-negative number of significant digits in its float argument. + "Return a non-negative number of significant digits in its float argument. Will be less than FLOAT-DIGITS if denormalized or zero." (macrolet ((frob (digits bias decode) `(cond ((zerop f) 0) @@ -277,9 +123,9 @@ (defun float-sign (float1 &optional (float2 (float 1 float1))) #!+sb-doc - "Returns a floating-point number that has the same sign as - float1 and, if float2 is given, has the same absolute value - as float2." + "Return a floating-point number that has the same sign as + FLOAT1 and, if FLOAT2 is given, has the same absolute value + as FLOAT2." (declare (float float1 float2)) (* (if (etypecase float1 (single-float (minusp (single-float-bits float1))) @@ -309,12 +155,7 @@ (defun float-radix (x) #!+sb-doc "Return (as an integer) the radix b of its floating-point argument." - (declare (type float x)) - ;; ANSI says this function "should signal an error if [..] argument - ;; is not a float". Since X is otherwise ignored, Python doesn't - ;; check the type by default, so we have to do it ourself: - (unless (floatp x) - (error 'type-error :datum x :expected-type 'float)) + (declare (ignore x)) 2) ;;;; INTEGER-DECODE-FLOAT and DECODE-FLOAT @@ -361,7 +202,7 @@ (t (values (logior sig sb!vm:single-float-hidden-bit) biased sign))))) -;;; Like INTEGER-DECODE-SINGLE-DENORM, only doubly so. +;;; like INTEGER-DECODE-SINGLE-DENORM, only doubly so (defun integer-decode-double-denorm (x) (declare (type double-float x)) (let* ((high-bits (double-float-high-bits (abs x))) @@ -393,7 +234,7 @@ (truly-the fixnum (- biased extra-bias)) sign))))) -;;; Like INTEGER-DECODE-SINGLE-FLOAT, only doubly so. +;;; like INTEGER-DECODE-SINGLE-FLOAT, only doubly so (defun integer-decode-double-float (x) (declare (double-float x)) (let* ((abs (abs x)) @@ -472,7 +313,7 @@ ;;; Dispatch to the correct type-specific i-d-f function. (defun integer-decode-float (x) #!+sb-doc - "Returns three values: + "Return three values: 1) an integer representation of the significand. 2) the exponent for the power of 2 that the significand must be multiplied by to get the actual value. This differs from the DECODE-FLOAT exponent @@ -525,7 +366,7 @@ bits)) biased sign))))) -;;; Like DECODE-SINGLE-DENORM, only doubly so. +;;; like DECODE-SINGLE-DENORM, only doubly so (defun decode-double-denorm (x) (declare (double-float x)) (multiple-value-bind (sig exp sign) (integer-decode-double-denorm x) @@ -538,7 +379,7 @@ (truly-the fixnum (+ exp sb!vm:double-float-digits)) (float sign x)))) -;;; Like DECODE-SINGLE-FLOAT, only doubly so. +;;; like DECODE-SINGLE-FLOAT, only doubly so (defun decode-double-float (x) (declare (double-float x)) (let* ((abs (abs x)) @@ -597,7 +438,7 @@ ;;; Dispatch to the appropriate type-specific function. (defun decode-float (f) #!+sb-doc - "Returns three values: + "Return three values: 1) a floating-point number representing the significand. This is always between 0.5 (inclusive) and 1.0 (exclusive). 2) an integer representing the exponent. @@ -671,8 +512,12 @@ :operands (list x exp))) (* (float-sign x) (etypecase x - (single-float single-float-positive-infinity) - (double-float double-float-positive-infinity)))))) + (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))))))) ;;; Scale a single or double float, calling the correct over/underflow ;;; functions. @@ -719,7 +564,7 @@ ;;; Dispatch to the correct type-specific scale-float function. (defun scale-float (f ex) #!+sb-doc - "Returns the value (* f (expt (float 2 f) ex)), but with no unnecessary loss + "Return the value (* f (expt (float 2 f) ex)), but with no unnecessary loss of precision or overflow." (number-dispatch ((f float)) ((single-float) @@ -828,9 +673,9 @@ (incf scale))))))) #| -These might be useful if we ever have a machine w/o float/integer conversion -hardware. For now, we'll use special ops that uninterruptibly frob the -rounding modes & do ieee round-to-integer. +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 @@ -862,19 +707,19 @@ rounding modes & do ieee round-to-integer. (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:word-bits) + (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:word-bits sb!vm:double-float-digits)) + (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:word-bits)))) + (- shift sb!vm:n-word-bits)))) res-hi))) (declare (type (unsigned-byte 31) res-hi res)) (if (minusp hi-bits)