(defknown %single-float (real) single-float (movable foldable flushable))
(defknown %double-float (real) double-float (movable foldable flushable))
-(deftransform float ((n &optional f) (* &optional single-float) *)
+(deftransform float ((n f) (* single-float) *)
'(%single-float n))
(deftransform float ((n f) (* double-float) *)
'(%double-float n))
+(deftransform float ((n) *)
+ '(if (floatp n)
+ n
+ (%single-float n)))
+
(deftransform %single-float ((n) (single-float) *)
'n)
;; to let me scan for places that I made this mistake and didn't
;; catch myself.
"use inline (UNSIGNED-BYTE 32) operations"
- (let ((num-high (numeric-type-high (continuation-type num))))
+ (let ((num-high (numeric-type-high (lvar-type num))))
(when (null num-high)
(give-up-ir1-transform))
- (cond ((constant-continuation-p num)
+ (cond ((constant-lvar-p num)
;; Check the worst case sum absolute error for the random number
;; expectations.
(let ((rem (rem (expt 2 32) num-high)))
(values double-float-significand double-float-int-exponent (integer -1 1))
(movable foldable flushable))
-(defknown scale-single-float (single-float fixnum) single-float
+(defknown scale-single-float (single-float integer) single-float
(movable foldable flushable))
-(defknown scale-double-float (double-float fixnum) double-float
+(defknown scale-double-float (double-float integer) double-float
(movable foldable flushable))
(deftransform decode-float ((x) (single-float) *)
(deftransform scale-float ((f ex) (single-float *) *)
(if (and #!+x86 t #!-x86 nil
- (csubtypep (continuation-type ex)
+ (csubtypep (lvar-type ex)
(specifier-type '(signed-byte 32))))
'(coerce (%scalbn (coerce f 'double-float) ex) 'single-float)
'(scale-single-float f ex)))
(deftransform scale-float ((f ex) (double-float *) *)
(if (and #!+x86 t #!-x86 nil
- (csubtypep (continuation-type ex)
+ (csubtypep (lvar-type ex)
(specifier-type '(signed-byte 32))))
'(%scalbn f ex)
'(scale-double-float f ex)))
;;; rational arithmetic, or different float types, and fix it up. If
;;; we don't, he won't even get so much as an efficiency note.
(deftransform float-contagion-arg1 ((x y) * * :defun-only t :node node)
- `(,(continuation-fun-name (basic-combination-fun node))
+ `(,(lvar-fun-name (basic-combination-fun node))
(float x y) y))
(deftransform float-contagion-arg2 ((x y) * * :defun-only t :node node)
- `(,(continuation-fun-name (basic-combination-fun node))
+ `(,(lvar-fun-name (basic-combination-fun node))
x (float y x)))
(dolist (x '(+ * / -))
(macrolet ((frob (op)
`(deftransform ,op ((x y) (float rational) *)
"open-code FLOAT to RATIONAL comparison"
- (unless (constant-continuation-p y)
+ (unless (constant-lvar-p y)
(give-up-ir1-transform
"The RATIONAL value isn't known at compile time."))
- (let ((val (continuation-value y)))
+ (let ((val (lvar-value y)))
(unless (eql (rational (float val)) val)
(give-up-ir1-transform
"~S doesn't have a precise float representation."
(setf (fun-info-derive-type (fun-info-or-lose name))
(lambda (call)
(declare (type combination call))
- (when (csubtypep (continuation-type
+ (when (csubtypep (lvar-type
(first (combination-args call)))
type)
(specifier-type 'float)))))))
#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (log derive-type) ((x &optional y))
- (when (and (csubtypep (continuation-type x)
+ (when (and (csubtypep (lvar-type x)
(specifier-type '(real 0.0)))
(or (null y)
- (csubtypep (continuation-type y)
+ (csubtypep (lvar-type y)
(specifier-type '(real 0.0)))))
(specifier-type 'float)))
\f
(declare (ignorable prim-quick))
`(progn
(deftransform ,name ((x) (single-float) *)
- #!+x86 (cond ((csubtypep (continuation-type x)
+ #!+x86 (cond ((csubtypep (lvar-type x)
(specifier-type '(single-float
(#.(- (expt 2f0 64)))
(#.(expt 2f0 64)))))
`(coerce (,',prim-quick (coerce x 'double-float))
'single-float))
(t
- (compiler-note
+ (compiler-notify
"unable to avoid inline argument range check~@
because the argument range (~S) was not within 2^64"
- (type-specifier (continuation-type x)))
+ (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 (continuation-type x)
+ #!+x86 (cond ((csubtypep (lvar-type x)
(specifier-type '(double-float
(#.(- (expt 2d0 64)))
(#.(expt 2d0 64)))))
`(,',prim-quick x))
(t
- (compiler-note
+ (compiler-notify
"unable to avoid inline argument range check~@
because the argument range (~S) was not within 2^64"
- (type-specifier (continuation-type x)))
+ (type-specifier (lvar-type x)))
`(,',prim x)))
#!-x86 `(,',prim x)))))
(def sin %sin %sin-quick)
(specifier-type `(or (,float-type ,(or lo '*) ,(or hi '*))
(complex ,float-type)))))
+) ; PROGN
+
+(eval-when (:compile-toplevel :execute)
+ ;; So the problem with this hack is that it's actually broken. If
+ ;; the host does not have long floats, then setting *R-D-F-F* to
+ ;; LONG-FLOAT doesn't actually buy us anything. FIXME.
+ (setf *read-default-float-format*
+ #!+long-float 'long-float #!-long-float 'double-float))
;;; Test whether the numeric-type ARG is within in domain specified by
;;; DOMAIN-LOW and DOMAIN-HIGH, consider negative and positive zero to
-;;; be distinct.
+;;; be distinct.
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defun domain-subtypep (arg domain-low domain-high)
(declare (type numeric-type arg)
(type (or real null) domain-low domain-high))
;; Check that the ARG bounds are correctly canonicalized.
(when (and arg-lo (floatp arg-lo-val) (zerop arg-lo-val) (consp arg-lo)
(minusp (float-sign arg-lo-val)))
- (compiler-note "float zero bound ~S not correctly canonicalized?" arg-lo)
- (setq arg-lo '(0l0) arg-lo-val 0l0))
+ (compiler-notify "float zero bound ~S not correctly canonicalized?" arg-lo)
+ (setq arg-lo 0e0 arg-lo-val arg-lo))
(when (and arg-hi (zerop arg-hi-val) (floatp arg-hi-val) (consp arg-hi)
(plusp (float-sign arg-hi-val)))
- (compiler-note "float zero bound ~S not correctly canonicalized?" arg-hi)
- (setq arg-hi '(-0l0) arg-hi-val -0l0))
- (and (or (null domain-low)
- (and arg-lo (>= arg-lo-val domain-low)
- (not (and (zerop domain-low) (floatp domain-low)
- (plusp (float-sign domain-low))
- (zerop arg-lo-val) (floatp arg-lo-val)
- (if (consp arg-lo)
- (plusp (float-sign arg-lo-val))
- (minusp (float-sign arg-lo-val)))))))
- (or (null domain-high)
- (and arg-hi (<= arg-hi-val domain-high)
- (not (and (zerop domain-high) (floatp domain-high)
- (minusp (float-sign domain-high))
- (zerop arg-hi-val) (floatp arg-hi-val)
- (if (consp arg-hi)
- (minusp (float-sign arg-hi-val))
- (plusp (float-sign arg-hi-val))))))))))
+ (compiler-notify "float zero bound ~S not correctly canonicalized?" arg-hi)
+ (setq arg-hi (ecase *read-default-float-format*
+ (double-float (load-time-value (make-unportable-float :double-float-negative-zero)))
+ #!+long-float
+ (long-float (load-time-value (make-unportable-float :long-float-negative-zero))))
+ arg-hi-val arg-hi))
+ (flet ((fp-neg-zero-p (f) ; Is F -0.0?
+ (and (floatp f) (zerop f) (minusp (float-sign f))))
+ (fp-pos-zero-p (f) ; Is F +0.0?
+ (and (floatp f) (zerop f) (plusp (float-sign f)))))
+ (and (or (null domain-low)
+ (and arg-lo (>= arg-lo-val domain-low)
+ (not (and (fp-pos-zero-p domain-low)
+ (fp-neg-zero-p arg-lo)))))
+ (or (null domain-high)
+ (and arg-hi (<= arg-hi-val domain-high)
+ (not (and (fp-neg-zero-p domain-high)
+ (fp-pos-zero-p arg-hi)))))))))
+(eval-when (:compile-toplevel :execute)
+ (setf *read-default-float-format* 'single-float))
+
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
+(progn
;;; Handle monotonic functions of a single variable whose domain is
;;; possibly part of the real line. ARG is the variable, FCN is the
(frob atanh -1d0 1d0 -1 1)
;; Kahan says that (sqrt -0.0) is -0.0, so use a specifier that
;; includes -0.0.
- (frob sqrt -0d0 nil 0 nil))
+ (frob sqrt (load-time-value (make-unportable-float :double-float-negative-zero)) nil 0 nil))
;;; Compute bounds for (expt x y). This should be easy since (expt x
;;; y) = (exp (* y (log x))). However, computations done this way
;;; have too much roundoff. Thus we have to do it the hard way.
(defun safe-expt (x y)
(handler-case
- (expt x y)
+ (when (< (abs y) 10000)
+ (expt x y))
(error ()
nil)))
;;; Handle the case when x >= 1.
(defun interval-expt-> (x y)
(case (sb!c::interval-range-info y 0d0)
- ('+
+ (+
;; Y is positive and log X >= 0. The range of exp(y * log(x)) is
;; obviously non-negative. We just have to be careful for
;; infinite bounds (given by nil).
(hi (safe-expt (type-bound-number (sb!c::interval-high x))
(type-bound-number (sb!c::interval-high y)))))
(list (sb!c::make-interval :low (or lo 1) :high hi))))
- ('-
+ (-
;; Y is negative and log x >= 0. The range of exp(y * log(x)) is
;; obviously [0, 1]. However, underflow (nil) means 0 is the
;; result.
;;; Handle the case when x <= 1
(defun interval-expt-< (x y)
(case (sb!c::interval-range-info x 0d0)
- ('+
+ (+
;; The case of 0 <= x <= 1 is easy
(case (sb!c::interval-range-info y)
- ('+
+ (+
;; Y is positive and log X <= 0. The range of exp(y * log(x)) is
;; obviously [0, 1]. We just have to be careful for infinite bounds
;; (given by nil).
(hi (safe-expt (type-bound-number (sb!c::interval-high x))
(type-bound-number (sb!c::interval-low y)))))
(list (sb!c::make-interval :low (or lo 0) :high (or hi 1)))))
- ('-
+ (-
;; Y is negative and log x <= 0. The range of exp(y * log(x)) is
;; obviously [1, inf].
(let ((hi (safe-expt (type-bound-number (sb!c::interval-low x))
(sb!c::interval-split 0 y t)
(list (interval-expt-< x y-)
(interval-expt-< x y+))))))
- ('-
+ (-
;; The case where x <= 0. Y MUST be an INTEGER for this to work!
;; The calling function must insure this! For now we'll just
;; return the appropriate unbounded float type.
;;; Compute bounds for (expt x y).
(defun interval-expt (x y)
(case (interval-range-info x 1)
- ('+
+ (+
;; X >= 1
(interval-expt-> x y))
- ('-
+ (-
;; X <= 1
(interval-expt-< x y))
(t
((csubtypep y (specifier-type 'integer))
;; A real raised to an integer power is well-defined.
(merged-interval-expt x y))
+ ;; A real raised to a non-integral power can be a float or a
+ ;; complex number.
+ ((or (csubtypep x (specifier-type '(rational 0)))
+ (csubtypep x (specifier-type '(float (0d0)))))
+ ;; 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)))
+ ;; 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))))
(t
- ;; A real raised to a non-integral power can be a float or a
- ;; complex number.
- (cond ((or (csubtypep x (specifier-type '(rational 0)))
- (csubtypep x (specifier-type '(float (0d0)))))
- ;; But a positive real to any power is well-defined.
- (merged-interval-expt x y))
- (t
- ;; a real to some power. The result could be a real
- ;; or a complex.
- (float-or-complex-float-type (numeric-contagion x y)))))))
+ ;; a real to some power. The result could be a real or a
+ ;; complex.
+ (float-or-complex-float-type (numeric-contagion x y)))))
(defoptimizer (expt derive-type) ((x y))
(two-arg-derive-type x y #'expt-derive-type-aux #'expt))
(bound-type (or format 'float)))
(cond ((numeric-type-real-p arg)
(case (interval-range-info (numeric-type->interval arg) 0.0)
- ('+
+ (+
;; The number is positive, so the phase is 0.
(make-numeric-type :class 'float
:format format
:complexp :real
:low (coerce 0 bound-type)
:high (coerce 0 bound-type)))
- ('-
+ (-
;; The number is always negative, so the phase is pi.
(make-numeric-type :class 'float
:format format
;;; FIXME: ANSI allows any subtype of REAL for the components of COMPLEX.
;;; So what if the input type is (COMPLEX (SINGLE-FLOAT 0 1))?
(defoptimizer (conjugate derive-type) ((num))
- (continuation-type num))
+ (lvar-type num))
(defoptimizer (cis derive-type) ((num))
(one-arg-derive-type num
(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))
+ '(,fun x))))
+ (def single-float %unary-ftruncate/single)
+ (def double-float %unary-ftruncate/double))
projects / sbcl.git / blobdiff