;;;; 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))
(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.
(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!
(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)))))
(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)))))
(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)))))
(,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)))))
projects / sbcl.git / blobdiff