;;; 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))))
\f
;;;; float accessors
(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)))
(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
;;; 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)))))
(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)))))
(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)
(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.
((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))
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))
- (continuation-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
\f
(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