(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* (arg &rest others)
+ (cond ((not others) arg)
+ ((not (cdr others)) `(cons ,arg ,(car others)))
+ (t (values nil t))))
+
+(defoptimizer (list* derive-type) ((arg &rest args))
+ (if args
+ (specifier-type 'cons)
+ (lvar-type arg)))
+
;;; 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))
+(deftransform last ((list &optional n) (t &optional t))
+ (let ((c (constant-lvar-p n)))
+ (cond ((or (not n)
+ (and c (eql 1 (lvar-value n))))
+ '(%last1 list))
+ ((and c (eql 0 (lvar-value n)))
+ '(%last0 list))
+ (t
+ (let ((type (lvar-type n)))
+ (cond ((csubtypep type (specifier-type 'fixnum))
+ '(%lastn/fixnum list n))
+ ((csubtypep type (specifier-type 'bignum))
+ '(%lastn/bignum list n))
+ (t
+ (give-up-ir1-transform "second argument type too vague"))))))))
+
(define-source-transform gethash (&rest args)
(case (length args)
- (2 `(sb!impl::gethash2 ,@args))
+ (2 `(sb!impl::gethash3 ,@args nil))
(3 `(sb!impl::gethash3 ,@args))
(t (values nil t))))
(define-source-transform get (&rest args)
(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)
nil
(set-bound y (consp x)))))))
+(defun safe-double-coercion-p (x)
+ (or (typep x 'double-float)
+ (<= most-negative-double-float x most-positive-double-float)))
+
+(defun safe-single-coercion-p (x)
+ (or (typep x 'single-float)
+ ;; Fix for bug 420, and related issues: during type derivation we often
+ ;; end up deriving types for both
+ ;;
+ ;; (some-op <int> <single>)
+ ;; and
+ ;; (some-op (coerce <int> 'single-float) <single>)
+ ;;
+ ;; or other equivalent transformed forms. The problem with this is that
+ ;; on some platforms like x86 (+ <int> <single>) is on the machine level
+ ;; equivalent of
+ ;;
+ ;; (coerce (+ (coerce <int> 'double-float)
+ ;; (coerce <single> 'double-float))
+ ;; 'single-float)
+ ;;
+ ;; so if the result of (coerce <int> 'single-float) is not exact, the
+ ;; derived types for the transformed forms will have an empty
+ ;; intersection -- which in turn means that the compiler will conclude
+ ;; that the call never returns, and all hell breaks lose when it *does*
+ ;; return at runtime. (This affects not just +, but other operators are
+ ;; well.)
+ (and (not (typep x `(or (integer * (,most-negative-exactly-single-float-fixnum))
+ (integer (,most-positive-exactly-single-float-fixnum) *))))
+ (<= most-negative-single-float x most-positive-single-float))))
+
;;; 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.
(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))))
+ ((typep ,x 'double-float)
+ (when (safe-double-coercion-p ,y)
+ (,op ,x ,y)))
+ ((typep ,y 'double-float)
+ (when (safe-double-coercion-p ,x)
+ (,op ,x ,y)))
+ ((typep ,x 'single-float)
+ (when (safe-single-coercion-p ,y)
+ (,op ,x ,y)))
+ ((typep ,y 'single-float)
+ (when (safe-single-coercion-p ,x)
+ (,op ,x ,y)))
+ (t (,op ,x ,y))))
(defmacro bound-binop (op x y)
`(and ,x ,y
;;; 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))
;; Multiply by closed zero is special. The result
;; is always a closed bound. But don't replace this
;; with zero; we want the multiplication to produce
- ;; the correct signed zero, if needed.
- (* (type-bound-number x) (type-bound-number y)))
+ ;; the correct signed zero, if needed. Use SIGNUM
+ ;; to avoid trying to multiply huge bignums with 0.0.
+ (* (signum (type-bound-number x)) (signum (type-bound-number y))))
((or (and (floatp x) (float-infinity-p x))
(and (floatp y) (float-infinity-p y)))
;; Infinity times anything is infinity
(>= (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)
(if (member-type-p arg)
;; Run down the list of members and convert to a list of
;; member types.
- (dolist (member (member-type-members arg))
- (push (if (numberp member)
- (make-member-type :members (list member))
- *empty-type*)
- new-args))
+ (mapc-member-type-members
+ (lambda (member)
+ (push (if (numberp member)
+ (make-member-type :members (list member))
+ *empty-type*)
+ new-args))
+ arg)
(push arg new-args)))
(unless (member *empty-type* new-args)
new-args)))))
(t
;; (float x (+0.0)) => (or (member -0.0) (float x (0.0)))
;; (float x -0.0) => (or (member -0.0) (float x (0.0)))
- (list (make-member-type :members (list (float -0.0 hi-val)))
+ (list (make-member-type :members (list (float (load-time-value (make-unportable-float :single-float-negative-zero)) hi-val)))
(make-numeric-type :class (numeric-type-class type)
:format (numeric-type-format type)
:complexp :real
;;; XXX This would be far simpler if the type-union methods could handle
;;; member/number unions.
(defun make-canonical-union-type (type-list)
- (let ((members '())
+ (let ((xset (alloc-xset))
+ (fp-zeroes '())
(misc-types '()))
(dolist (type type-list)
- (if (member-type-p type)
- (setf members (union members (member-type-members type)))
- (push type misc-types)))
- #!+long-float
- (when (null (set-difference `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members))
- (push (specifier-type '(long-float 0.0l0 0.0l0)) misc-types)
- (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0))))
- (when (null (set-difference `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members))
- (push (specifier-type '(double-float 0.0d0 0.0d0)) misc-types)
- (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0))))
- (when (null (set-difference `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members))
- (push (specifier-type '(single-float 0.0f0 0.0f0)) misc-types)
- (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0))))
- (if members
- (apply #'type-union (make-member-type :members members) misc-types)
- (apply #'type-union misc-types))))
+ (cond ((member-type-p type)
+ (mapc-member-type-members
+ (lambda (member)
+ (if (fp-zero-p member)
+ (unless (member member fp-zeroes)
+ (pushnew member fp-zeroes))
+ (add-to-xset member xset)))
+ type))
+ (t
+ (push type misc-types))))
+ (if (and (xset-empty-p xset) (not fp-zeroes))
+ (apply #'type-union misc-types)
+ (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes) misc-types))))
;;; Convert a member type with a single member to a numeric type.
(defun convert-member-type (arg)
(hi-res (if hi (isqrt hi) '*)))
(specifier-type `(integer ,lo-res ,hi-res))))))
+(defoptimizer (char-code derive-type) ((char))
+ (let ((type (type-intersection (lvar-type char) (specifier-type 'character))))
+ (cond ((member-type-p type)
+ (specifier-type
+ `(member
+ ,@(loop for member in (member-type-members type)
+ when (characterp member)
+ collect (char-code member)))))
+ ((sb!kernel::character-set-type-p type)
+ (specifier-type
+ `(or
+ ,@(loop for (low . high)
+ in (character-set-type-pairs type)
+ collect `(integer ,low ,high)))))
+ ((csubtypep type (specifier-type 'base-char))
+ (specifier-type
+ `(mod ,base-char-code-limit)))
+ (t
+ (specifier-type
+ `(mod ,char-code-limit))))))
+
(defoptimizer (code-char derive-type) ((code))
(let ((type (lvar-type code)))
;; FIXME: unions of integral ranges? It ought to be easier to do
;;;
;;; and similar for other arguments.
-(defun make-modular-fun-type-deriver (prototype class width)
+(defun make-modular-fun-type-deriver (prototype kind width signedp)
+ (declare (ignore kind))
#!-sb-fluid
(binding* ((info (info :function :info prototype) :exit-if-null)
(fun (fun-info-derive-type info) :exit-if-null)
(mask-type (specifier-type
- (ecase class
- (:unsigned (let ((mask (1- (ash 1 width))))
- `(integer ,mask ,mask)))
- (:signed `(signed-byte ,width))))))
+ (ecase signedp
+ ((nil) (let ((mask (1- (ash 1 width))))
+ `(integer ,mask ,mask)))
+ ((t) `(signed-byte ,width))))))
(lambda (call)
(let ((res (funcall fun call)))
(when res
- (if (eq class :unsigned)
+ (if (eq signedp nil)
(logand-derive-type-aux res mask-type))))))
#!+sb-fluid
(lambda (call)
(fun (fun-info-derive-type info) :exit-if-null)
(res (funcall fun call) :exit-if-null)
(mask-type (specifier-type
- (ecase class
- (:unsigned (let ((mask (1- (ash 1 width))))
- `(integer ,mask ,mask)))
- (:signed `(signed-byte ,width))))))
- (if (eq class :unsigned)
+ (ecase signedp
+ ((nil) (let ((mask (1- (ash 1 width))))
+ `(integer ,mask ,mask)))
+ ((t) `(signed-byte ,width))))))
+ (if (eq signedp nil)
(logand-derive-type-aux res mask-type)))))
;;; Try to recursively cut all uses of LVAR to WIDTH bits.
;;; modular version, if it exists, or NIL. If we have changed
;;; anything, we need to flush old derived types, because they have
;;; nothing in common with the new code.
-(defun cut-to-width (lvar class width)
+(defun cut-to-width (lvar kind width signedp)
(declare (type lvar lvar) (type (integer 0) width))
(let ((type (specifier-type (if (zerop width)
'(eql 0)
- `(,(ecase class (:unsigned 'unsigned-byte)
- (:signed 'signed-byte))
+ `(,(ecase signedp
+ ((nil) 'unsigned-byte)
+ ((t) 'signed-byte))
,width)))))
(labels ((reoptimize-node (node name)
(setf (node-derived-type node)
(eq (basic-combination-kind node) :known))
(let* ((fun-ref (lvar-use (combination-fun node)))
(fun-name (leaf-source-name (ref-leaf fun-ref)))
- (modular-fun (find-modular-version fun-name class width)))
+ (modular-fun (find-modular-version fun-name kind signedp width)))
(when (and modular-fun
(not (and (eq fun-name 'logand)
(csubtypep
did-something))
(cut-lvar lvar))))
+(defun best-modular-version (width signedp)
+ ;; 1. exact width-matched :untagged
+ ;; 2. >/>= width-matched :tagged
+ ;; 3. >/>= width-matched :untagged
+ (let* ((uuwidths (modular-class-widths *untagged-unsigned-modular-class*))
+ (uswidths (modular-class-widths *untagged-signed-modular-class*))
+ (uwidths (merge 'list uuwidths uswidths #'< :key #'car))
+ (twidths (modular-class-widths *tagged-modular-class*)))
+ (let ((exact (find (cons width signedp) uwidths :test #'equal)))
+ (when exact
+ (return-from best-modular-version (values width :untagged signedp))))
+ (flet ((inexact-match (w)
+ (cond
+ ((eq signedp (cdr w)) (<= width (car w)))
+ ((eq signedp nil) (< width (car w))))))
+ (let ((tgt (find-if #'inexact-match twidths)))
+ (when tgt
+ (return-from best-modular-version
+ (values (car tgt) :tagged (cdr tgt)))))
+ (let ((ugt (find-if #'inexact-match uwidths)))
+ (when ugt
+ (return-from best-modular-version
+ (values (car ugt) :untagged (cdr ugt))))))))
+
(defoptimizer (logand optimizer) ((x y) node)
(let ((result-type (single-value-type (node-derived-type node))))
(when (numeric-type-p result-type)
(numberp high)
(>= low 0))
(let ((width (integer-length high)))
- (when (some (lambda (x) (<= width x))
- (modular-class-widths *unsigned-modular-class*))
- ;; FIXME: This should be (CUT-TO-WIDTH NODE WIDTH).
- (cut-to-width x :unsigned width)
- (cut-to-width y :unsigned width)
- nil ; After fixing above, replace with T.
- )))))))
+ (multiple-value-bind (w kind signedp)
+ (best-modular-version width nil)
+ (when w
+ ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP).
+ (cut-to-width x kind width signedp)
+ (cut-to-width y kind width signedp)
+ nil ; After fixing above, replace with T.
+ ))))))))
(defoptimizer (mask-signed-field optimizer) ((width x) node)
(let ((result-type (single-value-type (node-derived-type node))))
(high (numeric-type-high result-type)))
(when (and (numberp low) (numberp high))
(let ((width (max (integer-length high) (integer-length low))))
- (when (some (lambda (x) (<= width x))
- (modular-class-widths *signed-modular-class*))
- ;; FIXME: This should be (CUT-TO-WIDTH NODE WIDTH).
- (cut-to-width x :signed width)
- nil ; After fixing above, replace with T.
- )))))))
+ (multiple-value-bind (w kind)
+ (best-modular-version width t)
+ (when w
+ ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH T).
+ (cut-to-width x kind width t)
+ nil ; After fixing above, replace with T.
+ ))))))))
\f
;;; miscellanous numeric transforms
;;; -- 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))
(char-type (specifier-type 'character)))
- (flet ((simple-type-p (type)
- (csubtypep type (specifier-type '(or fixnum (not number)))))
- (fixnum-type-p (type)
+ (flet ((fixnum-type-p (type)
(csubtypep type (specifier-type 'fixnum))))
(cond
((same-leaf-ref-p x y) t)
(csubtypep y-type char-type))
'(char= x y))
((or (fixnum-type-p x-type) (fixnum-type-p y-type))
- (give-up-ir1-transform))
- ((or (simple-type-p x-type) (simple-type-p y-type))
+ (commutative-arg-swap node))
+ ((or (eq-comparable-type-p x-type) (eq-comparable-type-p y-type))
'(eq x y))
((and (not (constant-lvar-p y))
(or (constant-lvar-p x)
;;; 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
;;; 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))
+ :policy (>= speed space))
(unless (constant-lvar-p control)
(give-up-ir1-transform "The control string is not a constant."))
(let ((arg-names (make-gensym-list (length args))))
(declare (ignore control))
(format dest (formatter ,(lvar-value control)) ,@arg-names))))
-(deftransform format ((stream control &rest args) (stream function &rest t) *
- :policy (> speed space))
+(deftransform format ((stream control &rest args) (stream function &rest t))
(let ((arg-names (make-gensym-list (length args))))
`(lambda (stream control ,@arg-names)
(funcall control stream ,@arg-names)
nil)))
-(deftransform format ((tee control &rest args) ((member t) function &rest t) *
- :policy (> speed space))
+(deftransform format ((tee control &rest args) ((member t) function &rest t))
(let ((arg-names (make-gensym-list (length args))))
`(lambda (tee control ,@arg-names)
(declare (ignore tee))
(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)
;; we're prepared to handle which is basically something
;; that array-element-type can return.
(or (and (member-type-p cons-type)
- (null (rest (member-type-members cons-type)))
+ (eql 1 (member-type-size cons-type))
(null (first (member-type-members cons-type))))
(let ((car-type (cons-type-car-type cons-type)))
(and (member-type-p car-type)
- (null (rest (member-type-members car-type)))
- (or (symbolp (first (member-type-members car-type)))
- (numberp (first (member-type-members car-type)))
- (and (listp (first (member-type-members
- car-type)))
- (numberp (first (first (member-type-members
- car-type))))))
+ (eql 1 (member-type-members car-type))
+ (let ((elt (first (member-type-members car-type))))
+ (or (symbolp elt)
+ (numberp elt)
+ (and (listp elt)
+ (numberp (first elt)))))
(good-cons-type-p (cons-type-cdr-type cons-type))))))
(unconsify-type (good-cons-type)
;; Convert the "printed" respresentation of a cons
(eq (first (second good-cons-type)) 'member))
`(,(second (second good-cons-type))
,@(unconsify-type (caddr good-cons-type))))))
- (coerceable-p (c-type)
+ (coerceable-p (part)
;; Can the value be coerced to the given type? Coerce is
;; complicated, so we don't handle every possible case
;; here---just the most common and easiest cases:
;; the requested type, because (by assumption) COMPLEX
;; (and other difficult types like (COMPLEX INTEGER)
;; aren't specialized types.
- (let ((coerced-type c-type))
- (or (and (subtypep coerced-type 'float)
- (csubtypep value-type (specifier-type 'real)))
- (and (subtypep coerced-type
- '(or (complex single-float)
- (complex double-float)))
- (csubtypep value-type (specifier-type 'number))))))
+ (let ((coerced-type (careful-specifier-type part)))
+ (when coerced-type
+ (or (and (csubtypep coerced-type (specifier-type 'float))
+ (csubtypep value-type (specifier-type 'real)))
+ (and (csubtypep coerced-type
+ (specifier-type `(or (complex single-float)
+ (complex double-float))))
+ (csubtypep value-type (specifier-type 'number)))))))
(process-types (type)
;; FIXME: This needs some work because we should be able
;; to derive the resulting type better than just the
;; (DOUBLE-FLOAT 10d0 20d0) instead of just
;; double-float.
(cond ((member-type-p type)
- (let ((members (member-type-members type)))
- (if (every #'coerceable-p members)
- (specifier-type `(or ,@members))
- *universal-type*)))
+ (block punt
+ (let (members)
+ (mapc-member-type-members
+ (lambda (member)
+ (if (coerceable-p member)
+ (push member members)
+ (return-from punt *universal-type*)))
+ type)
+ (specifier-type `(or ,@members)))))
((and (cons-type-p type)
(good-cons-type-p type))
(let ((c-type (unconsify-type (type-specifier type))))
(specifier-type (consify element-type)))
(t
(error "can't understand type ~S~%" element-type))))))
- (cond ((array-type-p array-type)
- (get-element-type array-type))
- ((union-type-p array-type)
- (apply #'type-union
- (mapcar #'get-element-type (union-type-types array-type))))
- (t
- *universal-type*)))))
+ (labels ((recurse (type)
+ (cond ((array-type-p type)
+ (get-element-type type))
+ ((union-type-p type)
+ (apply #'type-union
+ (mapcar #'recurse (union-type-types type))))
+ (t
+ *universal-type*))))
+ (recurse array-type)))))
-;;; Like CMU CL, we use HEAPSORT. However, other than that, this code
-;;; isn't really related to the CMU CL code, since instead of trying
-;;; to generalize the CMU CL code to allow START and END values, this
-;;; code has been written from scratch following Chapter 7 of
-;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
(define-source-transform sb!impl::sort-vector (vector start end predicate key)
;; Like CMU CL, we use HEAPSORT. However, other than that, this code
;; isn't really related to the CMU CL code, since instead of trying
(start-1 (1- ,',start))
(current-heap-size (- ,',end ,',start))
(keyfun ,keyfun))
- (declare (type (integer -1 #.(1- most-positive-fixnum))
+ (declare (type (integer -1 #.(1- sb!xc:most-positive-fixnum))
start-1))
(declare (type index current-heap-size))
(declare (type function keyfun))
(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))
+ '(%policy-quality policy quality-name))
projects / sbcl.git / blobdiff