X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ffloat-tran.lisp;h=89c60d9d223253c28605e1c0419f45e9a1e3f5f7;hb=5cc68148d1a5f9bacf4eb12e396b680d992fc2c2;hp=96f51b1a246f626d4a63bca13686128b815a70ea;hpb=98a76d4426660876dec6649b1e228d2e5b47f579;p=sbcl.git diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 96f51b1..89c60d9 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) @@ -45,41 +50,52 @@ ;;; through the code this way. It would be nice to move this into the ;;; same file as the other RANDOM definitions. (deftransform random ((num &optional state) - ((integer 1 #.(expt 2 32)) &optional *)) + ((integer 1 #.(expt 2 sb!vm::n-word-bits)) &optional *)) ;; FIXME: I almost conditionalized this as #!+sb-doc. Find some way ;; of automatically finding #!+sb-doc in proximity to DEFTRANSFORM ;; 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)))) - (when (null num-high) - (give-up-ir1-transform)) - (cond ((constant-continuation-p num) - ;; Check the worst case sum absolute error for the random number - ;; expectations. - (let ((rem (rem (expt 2 32) num-high))) - (unless (< (/ (* 2 rem (- num-high rem)) num-high (expt 2 32)) - (expt 2 (- sb!kernel::random-integer-extra-bits))) - (give-up-ir1-transform - "The random number expectations are inaccurate.")) - (if (= num-high (expt 2 32)) - '(random-chunk (or state *random-state*)) - #!-x86 '(rem (random-chunk (or state *random-state*)) num) - #!+x86 - ;; Use multiplication, which is faster. - '(values (sb!bignum::%multiply - (random-chunk (or state *random-state*)) - num))))) - ((> num-high random-fixnum-max) - (give-up-ir1-transform - "The range is too large to ensure an accurate result.")) - #!+x86 - ((< num-high (expt 2 32)) - '(values (sb!bignum::%multiply (random-chunk (or state - *random-state*)) - num))) - (t - '(rem (random-chunk (or state *random-state*)) num))))) + (let ((type (lvar-type num)) + (limit (expt 2 sb!vm::n-word-bits)) + (random-chunk (ecase sb!vm::n-word-bits + (32 'random-chunk) + (64 'sb!kernel::big-random-chunk)))) + (if (numeric-type-p type) + (let ((num-high (numeric-type-high (lvar-type num)))) + (aver num-high) + (cond ((constant-lvar-p num) + ;; Check the worst case sum absolute error for the + ;; random number expectations. + (let ((rem (rem limit num-high))) + (unless (< (/ (* 2 rem (- num-high rem)) + num-high limit) + (expt 2 (- sb!kernel::random-integer-extra-bits))) + (give-up-ir1-transform + "The random number expectations are inaccurate.")) + (if (= num-high limit) + `(,random-chunk (or state *random-state*)) + #!-(or x86 x86-64) + `(rem (,random-chunk (or state *random-state*)) num) + #!+(or x86 x86-64) + ;; Use multiplication, which is faster. + `(values (sb!bignum::%multiply + (,random-chunk (or state *random-state*)) + num))))) + ((> num-high random-fixnum-max) + (give-up-ir1-transform + "The range is too large to ensure an accurate result.")) + #!+(or x86 x86-64) + ((< num-high limit) + `(values (sb!bignum::%multiply + (,random-chunk (or state *random-state*)) + num))) + (t + `(rem (,random-chunk (or state *random-state*)) num)))) + ;; KLUDGE: a relatively conservative treatment, but better + ;; than a bug (reported by PFD sbcl-devel towards the end of + ;; 2004-11. + '(rem (random-chunk (or state *random-state*)) num)))) ;;;; float accessors @@ -132,10 +148,10 @@ (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) *) @@ -152,14 +168,14 @@ (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))) @@ -269,10 +285,10 @@ ;;; 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 '(+ * / -)) @@ -293,10 +309,10 @@ (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." @@ -321,17 +337,17 @@ (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))) @@ -419,30 +435,30 @@ (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) @@ -538,9 +554,18 @@ (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)) @@ -551,28 +576,33 @@ ;; 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 @@ -672,21 +702,22 @@ (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). @@ -695,7 +726,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. @@ -714,10 +745,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). @@ -726,7 +757,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)) @@ -740,7 +771,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. @@ -754,10 +785,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 @@ -886,17 +917,21 @@ ((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)) @@ -969,14 +1004,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 @@ -1266,8 +1301,9 @@ ;;; ;;; FIXME: ANSI allows any subtype of REAL for the components of COMPLEX. ;;; So what if the input type is (COMPLEX (SINGLE-FLOAT 0 1))? +;;; Or (EQL #C(1 2))? (defoptimizer (conjugate derive-type) ((num)) - (continuation-type num)) + (lvar-type num)) (defoptimizer (cis derive-type) ((num)) (one-arg-derive-type num @@ -1322,3 +1358,56 @@ (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))