X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ffloat-tran.lisp;h=bd7e427e39f77eebf6a1e31eeea697d8501965ef;hb=d6f9676ae94419cb5544c45821a8d31adbc1fbe8;hp=a1184e12ae59221f26aa7c22738b823fe6ca8253;hpb=41affad5889b78b0f4666bb18cd6bce43b0538d4;p=sbcl.git diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index a1184e1..bd7e427 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -102,10 +102,36 @@ ;;;; float accessors (defknown make-single-float ((signed-byte 32)) single-float - (movable foldable flushable)) + (movable flushable)) (defknown make-double-float ((signed-byte 32) (unsigned-byte 32)) double-float - (movable foldable flushable)) + (movable flushable)) + +#-sb-xc-host +(deftransform make-single-float ((bits) + ((signed-byte 32))) + "Conditional constant folding" + (unless (constant-lvar-p bits) + (give-up-ir1-transform)) + (let* ((bits (lvar-value bits)) + (float (make-single-float bits))) + (when (float-nan-p float) + (give-up-ir1-transform)) + float)) + +#-sb-xc-host +(deftransform make-double-float ((hi lo) + ((signed-byte 32) (unsigned-byte 32))) + "Conditional constant folding" + (unless (and (constant-lvar-p hi) + (constant-lvar-p lo)) + (give-up-ir1-transform)) + (let* ((hi (lvar-value hi)) + (lo (lvar-value lo)) + (float (make-double-float hi lo))) + (when (float-nan-p float) + (give-up-ir1-transform)) + float)) (defknown single-float-bits (single-float) (signed-byte 32) (movable foldable flushable)) @@ -343,21 +369,26 @@ (if (minusp y) '(%negate x) 'x))))) - (def * single-float 1.0 -1.0) - (def * double-float 1.0d0 -1.0d0)) + (def single-float 1.0 -1.0) + (def double-float 1.0d0 -1.0d0)) ;;; Return the reciprocal of X if it can be represented exactly, NIL otherwise. (defun maybe-exact-reciprocal (x) (unless (zerop x) - (multiple-value-bind (significand exponent sign) - ;; Signals an error for NaNs and infinities. - (handler-case (integer-decode-float x) - (error () (return-from maybe-exact-reciprocal nil))) - (let ((expected (/ sign significand (expt 2 exponent)))) - (let ((reciprocal (/ 1 x))) - (multiple-value-bind (significand exponent sign) (integer-decode-float reciprocal) - (when (eql expected (* sign significand (expt 2 exponent))) - reciprocal))))))) + (handler-case + (multiple-value-bind (significand exponent sign) + (integer-decode-float x) + ;; only powers of 2 can be inverted exactly + (unless (zerop (logand significand (1- significand))) + (return-from maybe-exact-reciprocal nil)) + (let ((expected (/ sign significand (expt 2 exponent))) + (reciprocal (/ x))) + (multiple-value-bind (significand exponent sign) + (integer-decode-float reciprocal) + ;; Denorms can't be inverted safely. + (and (eql expected (* sign significand (expt 2 exponent))) + reciprocal)))) + (error () (return-from maybe-exact-reciprocal nil))))) ;;; Replace constant division by multiplication with exact reciprocal, ;;; if one exists. @@ -377,7 +408,7 @@ (def single-float) (def double-float)) -;;; Optimize addition and subsctraction of zero +;;; Optimize addition and subtraction of zero (macrolet ((def (op type &rest args) `(deftransform ,op ((x y) (,type (constant-arg (member ,@args))) * ;; Beware the SNaN! @@ -532,27 +563,27 @@ (deftransform ,name ((x) (single-float) *) #!+x86 (cond ((csubtypep (lvar-type x) (specifier-type '(single-float - (#.(- (expt 2f0 64))) - (#.(expt 2f0 64))))) + (#.(- (expt 2f0 63))) + (#.(expt 2f0 63))))) `(coerce (,',prim-quick (coerce x 'double-float)) 'single-float)) (t (compiler-notify "unable to avoid inline argument range check~@ - because the argument range (~S) was not within 2^64" + because the argument range (~S) was not within 2^63" (type-specifier (lvar-type x))) `(coerce (,',prim (coerce x 'double-float)) 'single-float))) #!-x86 `(coerce (,',prim (coerce x 'double-float)) 'single-float)) (deftransform ,name ((x) (double-float) *) #!+x86 (cond ((csubtypep (lvar-type x) (specifier-type '(double-float - (#.(- (expt 2d0 64))) - (#.(expt 2d0 64))))) + (#.(- (expt 2d0 63))) + (#.(expt 2d0 63))))) `(,',prim-quick x)) (t (compiler-notify "unable to avoid inline argument range check~@ - because the argument range (~S) was not within 2^64" + because the argument range (~S) was not within 2^63" (type-specifier (lvar-type x))) `(,',prim x))) #!-x86 `(,',prim x))))) @@ -917,11 +948,9 @@ (int-hi (if hi (ceiling (type-bound-number hi)) '*)) - (f-lo (if lo - (bound-func #'float lo) + (f-lo (or (bound-func #'float lo) '*)) - (f-hi (if hi - (bound-func #'float hi) + (f-hi (or (bound-func #'float hi) '*))) (specifier-type `(or (rational ,int-lo ,int-hi) (single-float ,f-lo, f-hi))))) @@ -951,11 +980,9 @@ (int-hi (if hi (ceiling (type-bound-number hi)) '*)) - (f-lo (if lo - (bound-func #'float lo) + (f-lo (or (bound-func #'float lo) '*)) - (f-hi (if hi - (bound-func #'float hi) + (f-hi (or (bound-func #'float hi) '*))) (specifier-type `(or (rational ,int-lo ,int-hi) (single-float ,f-lo, f-hi))))) @@ -1017,7 +1044,7 @@ ;; But a positive real to any power is well-defined. (merged-interval-expt x y)) ((and (csubtypep x (specifier-type 'rational)) - (csubtypep x (specifier-type 'rational))) + (csubtypep y (specifier-type 'rational))) ;; A rational to the power of a rational could be a rational ;; or a possibly-complex single float (specifier-type '(or rational single-float (complex single-float)))) @@ -1517,16 +1544,19 @@ (,type &optional (or ,type ,@other-float-arg-types integer)) * :result result) - (let ((result-type (lvar-derived-type result))) + (let* ((result-type (and result + (lvar-derived-type result))) + (compute-all (and (values-type-p result-type) + (not (type-single-value-p result-type))))) (if (or (not y) (and (constant-lvar-p y) (= 1 (lvar-value y)))) - (if (values-type-p result-type) + (if compute-all `(let ((res (,',unary x))) (values res (- x (,',coerce res)))) `(let ((res (,',unary x))) ;; Dummy secondary value! (values res x))) - (if (values-type-p result-type) + (if compute-all `(let* ((f (,',coerce y)) (res (,',unary (/ x f)))) (values res (- x (* f (,',coerce res)))))