From: Christophe Rhodes Date: Tue, 15 Jun 2004 17:00:45 +0000 (+0000) Subject: 0.8.11.10: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=43980afbf2f02ff68b3cfb62be9051fabe164de0;p=sbcl.git 0.8.11.10: Implement a slightly-broken %UNARY-FTRUNCATE ... slightly broken because it doesn't distinguish between positive and negative zeros ... however, it's better than before: x86/Linux is now down to 232 failures on ieeefp-tests 1.4 ... will fix the brokenness shortly --- diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 713f5da..15c45f6 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1043,7 +1043,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%SINGLE-FLOAT" "%SINH" "%SQRT" "%SXHASH-SIMPLE-STRING" "%SXHASH-SIMPLE-SUBSTRING" "%TAN" "%TAN-QUICK" - "%TANH" "%UNARY-ROUND" "%UNARY-TRUNCATE" + "%TANH" "%UNARY-ROUND" "%UNARY-TRUNCATE" "%UNARY-FTRUNCATE" "%WITH-ARRAY-DATA" "%WITH-ARRAY-DATA-MACRO" "*ALREADY-MAYBE-GCING*" "*CURRENT-LEVEL-IN-PRINT*" "*EMPTY-TYPE*" diff --git a/src/code/float.lisp b/src/code/float.lisp index 2d8d467..c0e0419 100644 --- a/src/code/float.lisp +++ b/src/code/float.lisp @@ -779,6 +779,13 @@ uninterruptibly frob the rounding modes & do ieee round-to-integer. (- rounded) rounded))))))) +(defun %unary-ftruncate (number) + (number-dispatch ((number real)) + ((integer) (float number)) + ((ratio) (float (truncate (numerator number) (denominator number)))) + (((foreach single-float double-float #!+long-float long-float)) + (%unary-ftruncate number)))) + (defun rational (x) #!+sb-doc "RATIONAL produces a rational number for any real numeric argument. This is diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 99972c8..7a644b3 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -675,14 +675,67 @@ (multiple-value-bind (res rem) (,op number divisor) (values (float res (if (floatp rem) rem 1.0)) rem)))) -(!define-float-rounding-function ffloor floor - "Same as FLOOR, but returns first value as a float.") -(!define-float-rounding-function fceiling ceiling - "Same as CEILING, but returns first value as a float." ) -(!define-float-rounding-function ftruncate truncate - "Same as TRUNCATE, but returns first value as a float.") -(!define-float-rounding-function fround round - "Same as ROUND, but returns first value as a float.") +(defun ftruncate (number &optional (divisor 1)) + #!+sb-doc + "Same as TRUNCATE, but returns first value as a float." + (macrolet ((ftruncate-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 #!+long-float long-float) + (or rational single-float)) + (if (eql divisor 1) + (let ((res (%unary-ftruncate number))) + (values res (- number (coerce res '(dispatch-type number))))) + (ftruncate-float (dispatch-type number)))) + #!+long-float + ((long-float (or single-float double-float long-float)) + (ftruncate-float long-float)) + #!+long-float + (((foreach double-float single-float) long-float) + (ftruncate-float long-float)) + ((double-float (or single-float double-float)) + (ftruncate-float double-float)) + ((single-float double-float) + (ftruncate-float double-float)) + (((foreach fixnum bignum ratio) + (foreach single-float double-float #!+long-float long-float)) + (ftruncate-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)))) + +;;; FIXME: this probably needs treatment similar to the use of +;;; %UNARY-FTRUNCATE for FTRUNCATE. +(defun fround (number &optional (divisor 1)) + "Same as ROUND, but returns first value as a float." + (multiple-value-bind (res rem) + (round number divisor) + (values (float res (if (floatp rem) rem 1.0)) rem))) ;;;; comparisons diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 413ca99..c18356b 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -1346,3 +1346,69 @@ (plusp number))) (values (1+ tru) (- rem ,defaulted-divisor)) (values tru rem))))) + +(defknown %unary-ftruncate (real) float (movable foldable flushable)) +(defknown %unary-ftruncate/single (single-float) single-float + (movable foldable flushable)) +(defknown %unary-ftruncate/double (double-float) double-float + (movable foldable flushable)) + +(defun %unary-ftruncate/single (x) + (declare (type single-float x)) + (declare (optimize speed (safety 0))) + (let* ((bits (single-float-bits x)) + (exp (ldb sb!vm:single-float-exponent-byte bits)) + (biased (the single-float-exponent + (- exp sb!vm:single-float-bias)))) + (declare (type (signed-byte 32) bits)) + (cond + ((= exp sb!vm:single-float-normal-exponent-max) x) + ((<= biased 0) (* x 0f0)) + ((>= biased (float-digits x)) x) + (t + (let ((frac-bits (- (float-digits x) biased))) + (setf bits (logandc2 bits (- (ash 1 frac-bits) 1))) + (make-single-float bits)))))) + +(defun %unary-ftruncate/double (x) + (declare (type double-float x)) + (declare (optimize speed (safety 0))) + (let* ((high (double-float-high-bits x)) + (low (double-float-low-bits x)) + (exp (ldb sb!vm:double-float-exponent-byte high)) + (biased (the double-float-exponent + (- exp sb!vm:double-float-bias)))) + (declare (type (signed-byte 32) high) + (type (unsigned-byte 32) low)) + (cond + ((= exp sb!vm:double-float-normal-exponent-max) x) + ((<= biased 0) (* x 0d0)) + ((>= biased (float-digits x)) x) + (t + (let ((frac-bits (- (float-digits x) biased))) + (cond ((< frac-bits 32) + (setf low (logandc2 low (- (ash 1 frac-bits) 1)))) + (t + (setf low 0) + (setf high (logandc2 high (- (ash 1 (- frac-bits 32)) 1))))) + (make-double-float high low)))))) + +(macrolet + ((def (float-type fun) + `(deftransform %unary-ftruncate ((x) (,float-type)) + (let ((x-type (lvar-type x)) + ;; these bounds may look wrong, but in fact they're + ;; right: floats within these bounds are those which + ;; TRUNCATE to a (SIGNED-BYTE 32). ROUND would be + ;; different. + (low-bound (coerce (- (ash 1 31)) ',float-type)) + (high-bound (coerce (ash 1 31) ',float-type))) + (if (csubtypep x-type + (specifier-type + `(,',float-type (,low-bound) (,high-bound)))) + '(coerce (%unary-truncate x) ',float-type) + `(if (< ,low-bound x ,high-bound) + (coerce (%unary-truncate x) ',',float-type) + (,',fun x))))))) + (def single-float %unary-ftruncate/single) + (def double-float %unary-ftruncate/double)) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 869f684..cbc59ca 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -1620,6 +1620,13 @@ #'%unary-truncate-derive-type-aux #'%unary-truncate)) +(defoptimizer (%unary-ftruncate derive-type) ((number)) + (let ((divisor (specifier-type '(integer 1 1)))) + (one-arg-derive-type number + #'(lambda (n) + (ftruncate-derive-type-quot-aux n divisor nil)) + #'%unary-ftruncate))) + ;;; Define optimizers for FLOOR and CEILING. (macrolet ((def (name q-name r-name) diff --git a/version.lisp-expr b/version.lisp-expr index 1d07f11..b7bac15 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.11.9" +"0.8.11.10"