(define-source-transform ninth (x) `(nth 8 ,x))
(define-source-transform tenth (x) `(nth 9 ,x))
+;;; LIST with one arg is an extremely common operation (at least inside
+;;; SBCL itself); translate it to CONS to take advantage of common
+;;; allocation routines.
+(define-source-transform list (&rest args)
+ (case (length args)
+ (1 `(cons ,(first args) nil))
+ (t (values nil t))))
+
+;;; And similarly for LIST*.
+(define-source-transform list* (&rest args)
+ (case (length args)
+ (2 `(cons ,(first args) ,(second args)))
+ (t (values nil t))))
+
;;; Translate RPLACx to LET and SETF.
(define-source-transform rplaca (x y)
(once-only ((n-x x))
(define-source-transform nth (n l) `(car (nthcdr ,n ,l)))
+(define-source-transform last (x) `(sb!impl::last1 ,x))
+(define-source-transform gethash (&rest args)
+ (case (length args)
+ (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)
(define-source-transform 1+ (x) `(+ ,x 1))
(define-source-transform 1- (x) `(- ,x 1))
-(define-source-transform oddp (x) `(not (zerop (logand ,x 1))))
-(define-source-transform evenp (x) `(zerop (logand ,x 1)))
+(define-source-transform oddp (x) `(logtest ,x 1))
+(define-source-transform evenp (x) `(not (logtest ,x 1)))
;;; Note that all the integer division functions are available for
;;; inline expansion.
#-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))
;;; 1] and Y = [1, 2] to determine intersection.
(defun interval-intersect-p (x y &optional closed-intervals-p)
(declare (type interval x y))
- (multiple-value-bind (intersect diff)
- (interval-intersection/difference (if closed-intervals-p
- (interval-closure x)
- x)
- (if closed-intervals-p
- (interval-closure y)
- y))
- (declare (ignore diff))
- intersect))
+ (and (interval-intersection/difference (if closed-intervals-p
+ (interval-closure x)
+ x)
+ (if closed-intervals-p
+ (interval-closure y)
+ y))
+ t))
;;; Are the two intervals adjacent? That is, is there a number
;;; between the two intervals that is not an element of either
(if (listp p)
(first p)
(list p)))
- (test-number (p int)
+ (test-number (p int bound)
;; Test whether P is in the interval.
- (when (interval-contains-p (type-bound-number p)
- (interval-closure int))
- (let ((lo (interval-low int))
- (hi (interval-high int)))
+ (let ((pn (type-bound-number p)))
+ (when (interval-contains-p pn (interval-closure int))
;; Check for endpoints.
- (cond ((and lo (= (type-bound-number p) (type-bound-number lo)))
- (not (and (consp p) (numberp lo))))
- ((and hi (= (type-bound-number p) (type-bound-number hi)))
- (not (and (numberp p) (consp hi))))
- (t t)))))
+ (let* ((lo (interval-low int))
+ (hi (interval-high int))
+ (lon (type-bound-number lo))
+ (hin (type-bound-number hi)))
+ (cond
+ ;; Interval may be a point.
+ ((and lon hin (= lon hin pn))
+ (and (numberp p) (numberp lo) (numberp hi)))
+ ;; Point matches the low end.
+ ;; [P] [P,?} => TRUE [P] (P,?} => FALSE
+ ;; (P [P,?} => TRUE P) [P,?} => FALSE
+ ;; (P (P,?} => TRUE P) (P,?} => FALSE
+ ((and lon (= pn lon))
+ (or (and (numberp p) (numberp lo))
+ (and (consp p) (eq :low bound))))
+ ;; [P] {?,P] => TRUE [P] {?,P) => FALSE
+ ;; P) {?,P] => TRUE (P {?,P] => FALSE
+ ;; P) {?,P) => TRUE (P {?,P) => FALSE
+ ((and hin (= pn hin))
+ (or (and (numberp p) (numberp hi))
+ (and (consp p) (eq :high bound))))
+ ;; Not an endpoint, all is well.
+ (t
+ t))))))
(test-lower-bound (p int)
;; P is a lower bound of an interval.
(if p
- (test-number p int)
+ (test-number p int :low)
(not (interval-bounded-p int 'below))))
(test-upper-bound (p int)
;; P is an upper bound of an interval.
(if p
- (test-number p int)
+ (test-number p int :high)
(not (interval-bounded-p int 'above)))))
(let ((x-lo-in-y (test-lower-bound x-lo y))
(x-hi-in-y (test-upper-bound x-hi y))
(>= (type-bound-number (interval-low x))
(type-bound-number (interval-high y)))))
+;;; Return T if X = Y.
+(defun interval-= (x y)
+ (declare (type interval x y))
+ (and (interval-bounded-p x 'both)
+ (interval-bounded-p y 'both)
+ (flet ((bound (v)
+ (if (numberp v)
+ v
+ ;; Open intervals cannot be =
+ (return-from interval-= nil))))
+ ;; Both intervals refer to the same point
+ (= (bound (interval-high x)) (bound (interval-low x))
+ (bound (interval-high y)) (bound (interval-low y))))))
+
+;;; Return T if X /= Y
+(defun interval-/= (x y)
+ (not (interval-intersect-p x y)))
+
;;; Return an interval that is the absolute value of X. Thus, if
;;; X = [-1 10], the result is [0, 10].
(defun interval-abs (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))
;;; Convert to EQL if both args are rational and complexp is specified
;;; and the same for both.
-(deftransform = ((x y) * *)
+(deftransform = ((x y) (number number) *)
"open code"
(let ((x-type (lvar-type x))
(y-type (lvar-type y)))
- (if (and (csubtypep x-type (specifier-type 'number))
- (csubtypep y-type (specifier-type 'number)))
- (cond ((or (and (csubtypep x-type (specifier-type 'float))
- (csubtypep y-type (specifier-type 'float)))
- (and (csubtypep x-type (specifier-type '(complex float)))
- (csubtypep y-type (specifier-type '(complex float)))))
- ;; They are both floats. Leave as = so that -0.0 is
- ;; handled correctly.
- (give-up-ir1-transform))
- ((or (and (csubtypep x-type (specifier-type 'rational))
- (csubtypep y-type (specifier-type 'rational)))
- (and (csubtypep x-type
- (specifier-type '(complex rational)))
- (csubtypep y-type
- (specifier-type '(complex rational)))))
- ;; They are both rationals and complexp is the same.
- ;; Convert to EQL.
- '(eql x y))
- (t
- (give-up-ir1-transform
- "The operands might not be the same type.")))
- (give-up-ir1-transform
- "The operands might not be the same type."))))
-
-;;; If LVAR's type is a numeric type, then return the type, otherwise
-;;; GIVE-UP-IR1-TRANSFORM.
-(defun numeric-type-or-lose (lvar)
- (declare (type lvar lvar))
- (let ((res (lvar-type lvar)))
- (unless (numeric-type-p res) (give-up-ir1-transform))
- res))
+ (cond ((or (and (csubtypep x-type (specifier-type 'float))
+ (csubtypep y-type (specifier-type 'float)))
+ (and (csubtypep x-type (specifier-type '(complex float)))
+ (csubtypep y-type (specifier-type '(complex float)))))
+ ;; They are both floats. Leave as = so that -0.0 is
+ ;; handled correctly.
+ (give-up-ir1-transform))
+ ((or (and (csubtypep x-type (specifier-type 'rational))
+ (csubtypep y-type (specifier-type 'rational)))
+ (and (csubtypep x-type
+ (specifier-type '(complex rational)))
+ (csubtypep y-type
+ (specifier-type '(complex rational)))))
+ ;; They are both rationals and complexp is the same.
+ ;; Convert to EQL.
+ '(eql x y))
+ (t
+ (give-up-ir1-transform
+ "The operands might not be the same type.")))))
+
+(defun maybe-float-lvar-p (lvar)
+ (neq *empty-type* (type-intersection (specifier-type 'float)
+ (lvar-type lvar))))
+
+(flet ((maybe-invert (node op inverted x y)
+ ;; Don't invert if either argument can be a float (NaNs)
+ (cond
+ ((or (maybe-float-lvar-p x) (maybe-float-lvar-p y))
+ (delay-ir1-transform node :constraint)
+ `(or (,op x y) (= x y)))
+ (t
+ `(if (,inverted x y) nil t)))))
+ (deftransform >= ((x y) (number number) * :node node)
+ "invert or open code"
+ (maybe-invert node '> '< x y))
+ (deftransform <= ((x y) (number number) * :node node)
+ "invert or open code"
+ (maybe-invert node '< '> x y)))
;;; See whether we can statically determine (< X Y) using type
;;; information. If X's high bound is < Y's low, then X < Y.
;;; NIL). If not, at least make sure any constant arg is second.
(macrolet ((def (name inverse reflexive-p surely-true surely-false)
`(deftransform ,name ((x y))
- (if (same-leaf-ref-p x y)
+ "optimize using intervals"
+ (if (and (same-leaf-ref-p x y)
+ ;; For non-reflexive functions we don't need
+ ;; to worry about NaNs: (non-ref-op NaN NaN) => false,
+ ;; but with reflexive ones we don't know...
+ ,@(when reflexive-p
+ '((and (not (maybe-float-lvar-p x))
+ (not (maybe-float-lvar-p y))))))
,reflexive-p
(let ((ix (or (type-approximate-interval (lvar-type x))
(give-up-ir1-transform)))
`(,',inverse y x))
(t
(give-up-ir1-transform))))))))
+ (def = = t (interval-= ix iy) (interval-/= ix iy))
+ (def /= /= nil (interval-/= ix iy) (interval-= ix iy))
(def < > nil (interval-< ix iy) (interval->= ix iy))
(def > < nil (interval-< iy ix) (interval->= iy ix))
(def <= >= t (interval->= iy ix) (interval-< iy ix))
;;; negated test as appropriate. If it is a degenerate one-arg call,
;;; then we transform to code that returns true. Otherwise, we bind
;;; all the arguments and expand into a bunch of IFs.
-(declaim (ftype (function (symbol list boolean t) *) multi-compare))
-(defun multi-compare (predicate args not-p type)
+(defun multi-compare (predicate args not-p type &optional force-two-arg-p)
(let ((nargs (length args)))
(cond ((< nargs 1) (values nil t))
((= nargs 1) `(progn (the ,type ,@args) t))
((= nargs 2)
(if not-p
`(if (,predicate ,(first args) ,(second args)) nil t)
- (values nil t)))
+ (if force-two-arg-p
+ `(,predicate ,(first args) ,(second args))
+ (values nil t))))
(t
(do* ((i (1- nargs) (1- i))
(last nil current)
(define-source-transform = (&rest args) (multi-compare '= args nil 'number))
(define-source-transform < (&rest args) (multi-compare '< args nil 'real))
(define-source-transform > (&rest args) (multi-compare '> args nil 'real))
-(define-source-transform <= (&rest args) (multi-compare '> args t 'real))
-(define-source-transform >= (&rest args) (multi-compare '< args t 'real))
+;;; We cannot do the inversion for >= and <= here, since both
+;;; (< NaN X) and (> NaN X)
+;;; are false, and we don't have type-inforation available yet. The
+;;; deftransforms for two-argument versions of >= and <= takes care of
+;;; the inversion to > and < when possible.
+(define-source-transform <= (&rest args) (multi-compare '<= args nil 'real))
+(define-source-transform >= (&rest args) (multi-compare '>= args nil 'real))
(define-source-transform char= (&rest args) (multi-compare 'char= args nil
'character))
'character))
(define-source-transform char-equal (&rest args)
- (multi-compare 'char-equal args nil 'character))
+ (multi-compare 'sb!impl::two-arg-char-equal args nil 'character t))
(define-source-transform char-lessp (&rest args)
- (multi-compare 'char-lessp args nil 'character))
+ (multi-compare 'sb!impl::two-arg-char-lessp args nil 'character t))
(define-source-transform char-greaterp (&rest args)
- (multi-compare 'char-greaterp args nil 'character))
+ (multi-compare 'sb!impl::two-arg-char-greaterp args nil 'character t))
(define-source-transform char-not-greaterp (&rest args)
- (multi-compare 'char-greaterp args t 'character))
+ (multi-compare 'sb!impl::two-arg-char-greaterp args t 'character t))
(define-source-transform char-not-lessp (&rest args)
- (multi-compare 'char-lessp args t 'character))
+ (multi-compare 'sb!impl::two-arg-char-lessp args t 'character t))
;;; This function does source transformation of N-arg inequality
;;; functions such as /=. This is similar to MULTI-COMPARE in the <3
(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)
(funcall control *standard-output* ,@arg-names)
nil)))
+(deftransform pathname ((pathspec) (pathname) *)
+ 'pathspec)
+
+(deftransform pathname ((pathspec) (string) *)
+ '(values (parse-namestring pathspec)))
+
(macrolet
((def (name)
`(defoptimizer (,name optimizer) ((control &rest args))
#+sb-xc-host ; Only we should be using these
(progn
(def style-warn)
- (def compiler-abort)
(def compiler-error)
(def compiler-warn)
(def compiler-style-warn)
(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))
+