(2 `(sb!impl::gethash2 ,@args))
(3 `(sb!impl::gethash3 ,@args))
(t (values nil t))))
+(define-source-transform get (&rest args)
+ (case (length args)
+ (2 `(sb!impl::get2 ,@args))
+ (3 `(sb!impl::get3 ,@args))
+ (t (values nil t))))
(defvar *default-nthcdr-open-code-limit* 6)
(defvar *extreme-nthcdr-open-code-limit* 20)
#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(deffrob ceiling))
-(define-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
+;;; This used to be a source transform (hence the lack of restrictions
+;;; on the argument types), but we make it a regular transform so that
+;;; the VM has a chance to see the bare LOGTEST and potentiall choose
+;;; to implement it differently. --njf, 06-02-2006
+(deftransform logtest ((x y) * *)
+ `(not (zerop (logand x y))))
(deftransform logbitp
((index integer) (unsigned-byte (or (signed-byte #.sb!vm:n-word-bits)
(if (and (floatp y)
(float-infinity-p y))
nil
- (set-bound (funcall f (type-bound-number x)) (consp x)))))))
+ (set-bound y (consp x)))))))
;;; Apply a binary operator OP to two bounds X and Y. The result is
;;; NIL if either is NIL. Otherwise bound is computed and the result
;;; is open if either X or Y is open.
;;;
;;; FIXME: only used in this file, not needed in target runtime
+
+;;; ANSI contaigon specifies coercion to floating point if one of the
+;;; arguments is floating point. Here we should check to be sure that
+;;; the other argument is within the bounds of that floating point
+;;; type.
+
+(defmacro safely-binop (op x y)
+ `(cond
+ ((typep ,x 'single-float)
+ (if (or (typep ,y 'single-float)
+ (<= most-negative-single-float ,y most-positive-single-float))
+ (,op ,x ,y)))
+ ((typep ,x 'double-float)
+ (if (or (typep ,y 'double-float)
+ (<= most-negative-double-float ,y most-positive-double-float))
+ (,op ,x ,y)))
+ ((typep ,y 'single-float)
+ (if (<= most-negative-single-float ,x most-positive-single-float)
+ (,op ,x ,y)))
+ ((typep ,y 'double-float)
+ (if (<= most-negative-double-float ,x most-positive-double-float)
+ (,op ,x ,y)))
+ (t (,op ,x ,y))))
+
(defmacro bound-binop (op x y)
`(and ,x ,y
(with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
- (set-bound (,op (type-bound-number ,x)
- (type-bound-number ,y))
+ (set-bound (safely-binop ,op (type-bound-number ,x)
+ (type-bound-number ,y))
(or (consp ,x) (consp ,y))))))
+(defun coerce-for-bound (val type)
+ (if (consp val)
+ (list (coerce-for-bound (car val) type))
+ (cond
+ ((subtypep type 'double-float)
+ (if (<= most-negative-double-float val most-positive-double-float)
+ (coerce val type)))
+ ((or (subtypep type 'single-float) (subtypep type 'float))
+ ;; coerce to float returns a single-float
+ (if (<= most-negative-single-float val most-positive-single-float)
+ (coerce val type)))
+ (t (coerce val type)))))
+
+(defun coerce-and-truncate-floats (val type)
+ (when val
+ (if (consp val)
+ (list (coerce-and-truncate-floats (car val) type))
+ (cond
+ ((subtypep type 'double-float)
+ (if (<= most-negative-double-float val most-positive-double-float)
+ (coerce val type)
+ (if (< val most-negative-double-float)
+ most-negative-double-float most-positive-double-float)))
+ ((or (subtypep type 'single-float) (subtypep type 'float))
+ ;; coerce to float returns a single-float
+ (if (<= most-negative-single-float val most-positive-single-float)
+ (coerce val type)
+ (if (< val most-negative-single-float)
+ most-negative-single-float most-positive-single-float)))
+ (t (coerce val type))))))
+
;;; Convert a numeric-type object to an interval object.
(defun numeric-type->interval (x)
(declare (type numeric-type x))
(when (eq (numeric-type-class result-type) 'float)
(setf result (interval-func
#'(lambda (x)
- (coerce x (or (numeric-type-format result-type)
- 'float)))
+ (coerce-for-bound x (or (numeric-type-format result-type)
+ 'float)))
result)))
(make-numeric-type
:class (if (and (eq (numeric-type-class x) 'integer)
(when (eq (numeric-type-class result-type) 'float)
(setf result (interval-func
#'(lambda (x)
- (coerce x (or (numeric-type-format result-type)
- 'float)))
+ (coerce-for-bound x (or (numeric-type-format result-type)
+ 'float)))
result)))
(make-numeric-type
:class (if (and (eq (numeric-type-class x) 'integer)
(when (eq (numeric-type-class result-type) 'float)
(setf result (interval-func
#'(lambda (x)
- (coerce x (or (numeric-type-format result-type)
- 'float)))
+ (coerce-for-bound x (or (numeric-type-format result-type)
+ 'float)))
result)))
(make-numeric-type
:class (if (and (eq (numeric-type-class x) 'integer)
(when (eq (numeric-type-class result-type) 'float)
(setf result (interval-func
#'(lambda (x)
- (coerce x (or (numeric-type-format result-type)
- 'float)))
+ (coerce-for-bound x (or (numeric-type-format result-type)
+ 'float)))
result)))
(make-numeric-type :class (numeric-type-class result-type)
:format (numeric-type-format result-type)
:class class
:format format
:complexp :real
- :low (coerce-numeric-bound (interval-low abs-bnd) bound-type)
- :high (coerce-numeric-bound
+ :low (coerce-and-truncate-floats (interval-low abs-bnd) bound-type)
+ :high (coerce-and-truncate-floats
(interval-high abs-bnd) bound-type))))))
#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(when (member rem-type '(float single-float double-float
#!+long-float long-float))
(setf rem (interval-func #'(lambda (x)
- (coerce x rem-type))
+ (coerce-for-bound x rem-type))
rem)))
(make-numeric-type :class class
:format format
;; Make sure that the limits on the interval have
;; the right type.
(setf rem (interval-func (lambda (x)
- (coerce x result-type))
+ (coerce-for-bound x result-type))
rem)))
(make-numeric-type :class class
:format format
;;; -- If both args are characters, convert to CHAR=. This is better than
;;; just converting to EQ, since CHAR= may have special compilation
;;; strategies for non-standard representations, etc.
-;;; -- If either arg is definitely a fixnum we punt and let the backend
-;;; deal with it.
+;;; -- If either arg is definitely a fixnum, we check to see if X is
+;;; constant and if so, put X second. Doing this results in better
+;;; code from the backend, since the backend assumes that any constant
+;;; argument comes second.
;;; -- If either arg is definitely not a number or a fixnum, then we
;;; can compare with EQ.
;;; -- Otherwise, we try to put the arg we know more about second. If X
;;; is constant then we put it second. If X is a subtype of Y, we put
;;; it second. These rules make it easier for the back end to match
;;; these interesting cases.
-(deftransform eql ((x y) * *)
+(deftransform eql ((x y) * * :node node)
"convert to simpler equality predicate"
(let ((x-type (lvar-type x))
(y-type (lvar-type y))
(csubtypep y-type char-type))
'(char= x y))
((or (fixnum-type-p x-type) (fixnum-type-p y-type))
- (give-up-ir1-transform))
+ (commutative-arg-swap node))
((or (simple-type-p x-type) (simple-type-p y-type))
'(eq x y))
((and (not (constant-lvar-p y))
(when (stringp x)
(check-format-args x args 'format)))))
+;;; We disable this transform in the cross-compiler to save memory in
+;;; the target image; most of the uses of FORMAT in the compiler are for
+;;; error messages, and those don't need to be particularly fast.
+#+sb-xc
(deftransform format ((dest control &rest args) (t simple-string &rest t) *
:policy (> speed space))
(unless (constant-lvar-p control)
(give-up-ir1-transform "not a real transform"))
(defun /report-lvar (x message)
(declare (ignore x message))))
+
+\f
+;;;; Transforms for internal compiler utilities
+
+;;; If QUALITY-NAME is constant and a valid name, don't bother
+;;; checking that it's still valid at run-time.
+(deftransform policy-quality ((policy quality-name)
+ (t symbol))
+ (unless (and (constant-lvar-p quality-name)
+ (policy-quality-name-p (lvar-value quality-name)))
+ (give-up-ir1-transform))
+ `(let* ((acons (assoc quality-name policy))
+ (result (or (cdr acons) 1)))
+ result))
projects / sbcl.git / blobdiff