X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fcompiler%2Fsrctran.lisp;h=bdab82c41f7f5a26902c960155731f028ce48640;hb=ab6672fd5c392b8678681bdda138c4dc9e4de31a;hp=2500787ea8ea0bc0de22e6b93d05d67acdc5a4fb;hpb=be2e8599a25b1a21fac40d963ec71820b74cf3f3;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 2500787..bdab82c 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -114,6 +114,20 @@
 (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))
@@ -131,7 +145,7 @@
 (define-source-transform last (x) `(sb!impl::last1 ,x))
 (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)
@@ -169,8 +183,8 @@
 (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.
@@ -188,7 +202,12 @@
   #-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)
@@ -301,7 +320,7 @@
            (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
@@ -317,10 +336,12 @@
 (defmacro safely-binop (op x y)
   `(cond
     ((typep ,x 'single-float)
-     (if (<= most-negative-single-float ,y most-positive-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 (<= most-negative-double-float ,y most-positive-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)
@@ -333,10 +354,41 @@
 (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))
@@ -459,15 +511,13 @@
 ;;; 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
@@ -511,27 +561,44 @@
            (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))
@@ -635,8 +702,9 @@
                   ;; 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
@@ -764,6 +832,24 @@
     (>= (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)
@@ -839,11 +925,13 @@
           (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)))))
@@ -1002,25 +1090,23 @@
 ;;; 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)
@@ -1229,8 +1315,8 @@
         (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)
@@ -1262,8 +1348,8 @@
         (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)
@@ -1295,8 +1381,8 @@
         (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)
@@ -1331,8 +1417,8 @@
         (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)
@@ -1475,8 +1561,8 @@
             :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.)
@@ -1590,7 +1676,7 @@
              (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
@@ -1700,7 +1786,7 @@
                    ;; 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
@@ -3229,27 +3315,31 @@
   (def eq)
   (def char=))
 
+;;; True if EQL comparisons involving type can be simplified to EQ.
+(defun eq-comparable-type-p (type)
+  (csubtypep type (specifier-type '(or fixnum (not number)))))
+
 ;;; This is similar to SIMPLE-EQUALITY-TRANSFORM, except that we also
 ;;; try to convert to a type-specific predicate or EQ:
 ;;; -- 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)
@@ -3259,8 +3349,8 @@
               (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)
@@ -3299,41 +3389,48 @@
 
 ;;; 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.
@@ -3341,7 +3438,14 @@
 ;;; 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)))
@@ -3356,6 +3460,8 @@
                              `(,',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))
@@ -3394,15 +3500,16 @@
 ;;; 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)
@@ -3420,8 +3527,13 @@
 (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))
@@ -3435,15 +3547,15 @@
                                                             '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
@@ -3626,6 +3738,10 @@
       (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)
@@ -3650,6 +3766,12 @@
        (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))
@@ -3662,7 +3784,6 @@
   #+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)
@@ -3769,17 +3890,16 @@
               ;; 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
@@ -3830,10 +3950,15 @@
               ;; (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))))
@@ -3997,3 +4122,16 @@
     (give-up-ir1-transform "not a real transform"))
   (defun /report-lvar (x message)
     (declare (ignore x message))))
+
+
+;;;; 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))
+