X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ffloat-tran.lisp;h=9e6033c1e9680b200480280b45707b8ecd7df917;hb=69ef68ba7393e3492c1b4a756d1140f71c2922bc;hp=413ca99e7e2fc2a35697f8ac9978ea5458e205db;hpb=c3699db2053ff3b5ac6a98d4431c3789496002d8;p=sbcl.git diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 413ca99..9e6033c 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -50,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 (lvar-type num)))) - (when (null num-high) - (give-up-ir1-transform)) - (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))) - (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 @@ -137,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) *) @@ -227,10 +238,18 @@ (ex-hi (numeric-type-high ex)) (new-lo nil) (new-hi nil)) - (when (and f-hi ex-hi) - (setf new-hi (scale-bound f-hi ex-hi))) - (when (and f-lo ex-lo) - (setf new-lo (scale-bound f-lo ex-lo))) + (when f-hi + (if (< (float-sign (type-bound-number f-hi)) 0.0) + (when ex-lo + (setf new-hi (scale-bound f-hi ex-lo))) + (when ex-hi + (setf new-hi (scale-bound f-hi ex-hi))))) + (when f-lo + (if (< (float-sign (type-bound-number f-lo)) 0.0) + (when ex-hi + (setf new-lo (scale-bound f-lo ex-hi))) + (when ex-lo + (setf new-lo (scale-bound f-lo ex-lo))))) (make-numeric-type :class (numeric-type-class f) :format (numeric-type-format f) :complexp :real @@ -613,9 +632,7 @@ (etypecase arg (numeric-type (cond ((eq (numeric-type-complexp arg) :complex) - (make-numeric-type :class (numeric-type-class arg) - :format (numeric-type-format arg) - :complexp :complex)) + (complex-float-type arg)) ((numeric-type-real-p arg) ;; The argument is real, so let's find the intersection ;; between the argument and the domain of the function. @@ -1286,19 +1303,34 @@ nil nil)) #'tan)) -;;; CONJUGATE always returns the same type as the input type. -;;; -;;; 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)) - (lvar-type num)) + (one-arg-derive-type num + (lambda (arg) + (flet ((most-negative-bound (l h) + (and l h + (if (< (type-bound-number l) (- (type-bound-number h))) + l + (set-bound (- (type-bound-number h)) (consp h))))) + (most-positive-bound (l h) + (and l h + (if (> (type-bound-number h) (- (type-bound-number l))) + h + (set-bound (- (type-bound-number l)) (consp l)))))) + (if (numeric-type-real-p arg) + (lvar-type num) + (let ((low (numeric-type-low arg)) + (high (numeric-type-high arg))) + (let ((new-low (most-negative-bound low high)) + (new-high (most-positive-bound low high))) + (modified-numeric-type arg :low new-low :high new-high)))))) + #'conjugate)) (defoptimizer (cis derive-type) ((num)) (one-arg-derive-type num - (lambda (arg) - (sb!c::specifier-type - `(complex ,(or (numeric-type-format arg) 'float)))) - #'cis)) + (lambda (arg) + (sb!c::specifier-type + `(complex ,(or (numeric-type-format arg) 'float)))) + #'cis)) ) ; PROGN @@ -1346,3 +1378,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))