Add a transform for EQUALP.

Similar to the EQUAL one.

Also fix a bug in the EQUAL transform when types which include
specialized arrays inside them were resulting in EQUAL being
incorrectly folded to NIL.

diff --git a/NEWS b/NEWS
index 1f9de42..0ec8409 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -4,8 +4,8 @@ changes relative to sbcl-1.1.11:
     shutdown(3). (thanks to Jan Moringen, lp#1207483)
   * enhancement: document extensible sequences.  (thanks to Jan Moringen,
     lp#994528)
-  * optimization: EQUAL transform is smarter.  (thanks to Elias Martenson,
-    lp#1220084)
+  * optimization: EQUAL and EQUALP transforms are smarter.
+    (thanks to Elias Martenson, lp#1220084)
   * bug fix: probe-file now can access symlinks to pipes and sockets in
     /proc/pid/fd on Linux. (reported by Eric Schulte)
   * bug fix: SBCL can now be built on Solaris x86-64.

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index eed15c2..7384efa 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -3821,28 +3821,72 @@
   "convert to simpler equality predicate"
   (let ((x-type (lvar-type x))
         (y-type (lvar-type y))
-        (string-type (specifier-type 'string))
-        (bit-vector-type (specifier-type 'bit-vector))
-        (pathname-type (specifier-type 'pathname))
         (combination-type (specifier-type '(or bit-vector string
                                             cons pathname))))
-    (cond
-      ((same-leaf-ref-p x y) t)
-      ((and (csubtypep x-type string-type)
-            (csubtypep y-type string-type))
-       '(string= x y))
-      ((and (csubtypep x-type bit-vector-type)
-            (csubtypep y-type bit-vector-type))
-       '(bit-vector-= x y))
-      ((and (csubtypep x-type pathname-type)
-            (csubtypep y-type pathname-type))
-       '(pathname= x y))
-      ((not (types-equal-or-intersect y-type x-type))
-       nil)
-      ((or (not (types-equal-or-intersect x-type combination-type))
-           (not (types-equal-or-intersect y-type combination-type)))
-       '(eql x y))
-      (t (give-up-ir1-transform)))))
+    (flet ((both-csubtypep (type)
+             (let ((ctype (specifier-type type)))
+               (and (csubtypep x-type ctype)
+                    (csubtypep y-type ctype)))))
+      (cond
+        ((same-leaf-ref-p x y) t)
+        ((both-csubtypep 'string)
+         '(string= x y))
+        ((both-csubtypep 'bit-vector)
+         '(bit-vector-= x y))
+        ((both-csubtypep 'pathname)
+         '(pathname= x y))
+        ((or (not (types-equal-or-intersect x-type combination-type))
+             (not (types-equal-or-intersect y-type combination-type)))
+         (if (types-equal-or-intersect x-type y-type)
+             '(eql x y)
+             ;; Can't simply check for type intersection if both types are combination-type
+             ;; since array specialization would mean types don't intersect, even when EQUAL
+             ;; doesn't care for specialization.
+             ;; Previously checking for intersection in the outer COND resulted in
+             ;;
+             ;; (equal (the (cons (or simple-bit-vector
+             ;;                       simple-base-string))
+             ;;             x)
+             ;;        (the (cons (or (and bit-vector (not simple-array))
+             ;;                       (simple-array character (*))))
+             ;;             y))
+             ;; being incorrectly folded to NIL
+             nil))
+        (t (give-up-ir1-transform))))))
+
+(deftransform equalp ((x y) * *)
+  "convert to simpler equality predicate"
+  (let ((x-type (lvar-type x))
+        (y-type (lvar-type y))
+        (combination-type (specifier-type '(or number array
+                                            character
+                                            cons pathname
+                                            instance hash-table))))
+    (flet ((both-csubtypep (type)
+             (let ((ctype (specifier-type type)))
+               (and (csubtypep x-type ctype)
+                    (csubtypep y-type ctype)))))
+      (cond
+        ((same-leaf-ref-p x y) t)
+        ((both-csubtypep 'string)
+         '(string-equal x y))
+        ((both-csubtypep 'bit-vector)
+         '(bit-vector-= x y))
+        ((both-csubtypep 'pathname)
+         '(pathname= x y))
+        ((both-csubtypep 'character)
+         '(char-equal x y))
+        ((both-csubtypep 'number)
+         '(= x y))
+        ((both-csubtypep 'hash-table)
+         '(hash-table-equalp x y))
+        ((or (not (types-equal-or-intersect x-type combination-type))
+             (not (types-equal-or-intersect y-type combination-type)))
+         ;; See the comment about specialized types in the EQUAL transform above
+         (if (types-equal-or-intersect y-type x-type)
+             '(eq x y)
+             nil))
+        (t (give-up-ir1-transform))))))
 
 ;;; Convert to EQL if both args are rational and complexp is specified
 ;;; and the same for both.

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 16b6e4f..cb285c5 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4771,11 +4771,7 @@
                         "23a%b%")))))
     (assert (funcall f))))
 
-(defvar *global-equal-function* #'equal
-  "Global reference to the EQUAL function. This reference is funcalled
-in order to prevent the compiler from inlining the call.")
-
-(defmacro equal-reduction-macro ()
+(with-test (:name :equal-equalp-transforms)
   (let* ((s "foo")
          (bit-vector #*11001100)
          (values `(nil 1 2 "test"
@@ -4784,19 +4780,45 @@ in order to prevent the compiler from inlining the call.")
                        (read-from-string "1.1") (read-from-string "1.2d0")
                        1.1 1.2d0 '("foo" "bar" "test")
                        #(1 2 3 4) #*101010 (make-broadcast-stream) #p"/tmp/file"
-                       ,s (copy-seq ,s) ,bit-vector (copy-seq ,bit-vector))))
+                       ,s (copy-seq ,s) ,bit-vector (copy-seq ,bit-vector)
+                       ,(make-hash-table) #\a #\b #\A #\C
+                       ,(make-random-state) 1/2 2/3)))
     ;; Test all permutations of different types
-    `(progn
-       ,@(loop
-            for x in values
-            append (loop
-                      for y in values
-                      collect (let ((result1-sym (gensym "RESULT1-"))
-                                    (result2-sym (gensym "RESULT2-")))
-                                `(let ((,result1-sym (equal ,x ,y))
-                                       (,result2-sym (funcall *global-equal-function* ,x ,y)))
-                                   (assert (or (and ,result1-sym ,result2-sym)
-                                               (and (not ,result1-sym) (not ,result2-sym)))))))))))
-
-(with-test (:name :equal-reduction)
-  (equal-reduction-macro))
+    (assert
+     (loop
+       for x in values
+       always (loop
+                for y in values
+                always
+                (and (eq (funcall (compile nil `(lambda (x y)
+                                                  (equal (the ,(type-of x) x)
+                                                         (the ,(type-of y) y))))
+                                  x y)
+                         (equal x y))
+                     (eq (funcall (compile nil `(lambda (x y)
+                                                  (equalp (the ,(type-of x) x)
+                                                          (the ,(type-of y) y))))
+                                  x y)
+                         (equalp x y))))))
+    (assert
+     (funcall (compile
+               nil
+               `(lambda (x y)
+                  (equal (the (cons (or simple-bit-vector simple-base-string))
+                              x)
+                         (the (cons (or (and bit-vector (not simple-array))
+                                        (simple-array character (*))))
+                              y))))
+              (list (string 'list))
+              (list "LIST")))
+    (assert
+     (funcall (compile
+               nil
+               `(lambda (x y)
+                  (equalp (the (cons (or simple-bit-vector simple-base-string))
+                               x)
+                          (the (cons (or (and bit-vector (not simple-array))
+                                         (simple-array character (*))))
+                               y))))
+              (list (string 'list))
+              (list "lisT")))))