X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ffloat-tran.lisp;h=42f18fa73ada25eccbe5238fd45b8cc4778ba4a6;hb=1b650be8b800cf96e2c268ae317fb26d0bf36827;hp=9ddb5aa889e2214f8c97d942889c2b6880377dfc;hpb=ff57884e206ac28660af6af34315bc9b81697f57;p=sbcl.git diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 9ddb5aa..42f18fa 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -18,12 +18,17 @@ (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) @@ -561,34 +566,27 @@ (when (and arg-lo (floatp arg-lo-val) (zerop arg-lo-val) (consp arg-lo) (minusp (float-sign arg-lo-val))) (compiler-notify "float zero bound ~S not correctly canonicalized?" arg-lo) - (setq arg-lo '(0e0) arg-lo-val 0e0)) + (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-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 (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)))))) - (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)))))))))) + (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)) @@ -700,14 +698,15 @@ ;;; 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). @@ -716,7 +715,7 @@ (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. @@ -735,10 +734,10 @@ ;;; 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). @@ -747,7 +746,7 @@ (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)) @@ -761,7 +760,7 @@ (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. @@ -775,10 +774,10 @@ ;;; 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 @@ -990,14 +989,14 @@ (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