1.0.4.66: Undo D-X changes in 1.0.4.63

[sbcl.git] / src / compiler / srctran.lisp

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 30c0c61..c39aeff 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -3410,20 +3410,24 @@
            (give-up-ir1-transform
             "The operands might not be the same type.")))))
 
-(labels ((maybe-float-lvar-p (lvar)
-           (neq *empty-type* (type-intersection (specifier-type 'float)
-                                                (lvar-type lvar))))
-         (maybe-invert (op inverted x y)
-           ;; Don't invert if either argument can be a float (NaNs)
-           (if (or (maybe-float-lvar-p x) (maybe-float-lvar-p y))
-               `(or (,op x y) (= x y))
-               `(if (,inverted x y) nil t))))
-  (deftransform >= ((x y) (number number) *)
+(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 '> '< x y))
-  (deftransform <= ((x y) (number number) *)
+    (maybe-invert node '> '< x y))
+  (deftransform <= ((x y) (number number) * :node node)
     "invert or open code"
-    (maybe-invert '< '> x y)))
+    (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.
@@ -3432,7 +3436,13 @@
 (macrolet ((def (name inverse reflexive-p surely-true surely-false)
              `(deftransform ,name ((x y))
                 "optimize using intervals"
-                (if (same-leaf-ref-p x y)
+                (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)))
@@ -3487,15 +3497,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)
@@ -3533,15 +3544,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