From 36717964ebcff8353035062789c08f223feccf1a Mon Sep 17 00:00:00 2001
From: Stas Boukarev <stassats@gmail.com>
Date: Thu, 5 Sep 2013 17:10:08 +0400
Subject: [PATCH] Improve the EQUAL transform.

Transform to EQL when at least one argument is not of type
(or string cons pathname bit-vector).
Transform (equal (the pathname x) (the pathname y)) to (pathname= x y).

Closes lp#1220084, based on the patch by Elias Martenson.
---
 NEWS                        |    2 ++
 package-data-list.lisp-expr |    1 +
 src/compiler/fndb.lisp      |    2 ++
 src/compiler/srctran.lisp   |   19 +++++++++++--------
 tests/compiler.pure.lisp    |   30 ++++++++++++++++++++++++++++++
 5 files changed, 46 insertions(+), 8 deletions(-)

diff --git a/NEWS b/NEWS
index 34b238a..900995a 100644
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,8 @@
 changes relative to sbcl-1.1.11:
   * enhancement: Add sb-bsd-sockets:socket-shutdown, for calling
     shutdown(3). (lp#1207483 patch by Jan Moringen)
+  * optimization: EQUAL transform is smarter.
+    (lp#1220084 thanks to Elias Martenson)
   * 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/package-data-list.lisp-expr b/package-data-list.lisp-expr
index cf8fd1e..d865cc9 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1065,6 +1065,7 @@ possibly temporariliy, because it might be used internally."
                "%BREAK"
                "NTH-BUT-WITH-SANE-ARG-ORDER"
                "BIT-VECTOR-="
+               "PATHNAME="
                "READ-EVALUATED-FORM"
                "MAKE-UNPRINTABLE-OBJECT"
                "POWER-OF-TWO-CEILING"
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 4089b77..d6546ce 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -1246,6 +1246,8 @@
 (defknown pathname-version (pathname-designator)
   pathname-version (flushable))
 
+(defknown pathname= (pathname pathname) boolean (movable foldable flushable))
+
 (defknown (namestring file-namestring directory-namestring host-namestring)
   (pathname-designator) (or simple-string null)
   (unsafely-flushable))
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 69275ff..eed15c2 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -3822,7 +3822,10 @@
   (let ((x-type (lvar-type x))
         (y-type (lvar-type y))
         (string-type (specifier-type 'string))
-        (bit-vector-type (specifier-type 'bit-vector)))
+        (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)
@@ -3831,14 +3834,14 @@
       ((and (csubtypep x-type bit-vector-type)
             (csubtypep y-type bit-vector-type))
        '(bit-vector-= x y))
-      ;; if at least one is not a string, and at least one is not a
-      ;; bit-vector, then we can reason from types.
-      ((and (not (and (types-equal-or-intersect x-type string-type)
-                      (types-equal-or-intersect y-type string-type)))
-            (not (and (types-equal-or-intersect x-type bit-vector-type)
-                      (types-equal-or-intersect y-type bit-vector-type)))
-            (not (types-equal-or-intersect x-type y-type)))
+      ((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)))))
 
 ;;; Convert to EQL if both args are rational and complexp is specified
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 16436ff..16b6e4f 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4770,3 +4770,33 @@
                              G13908)))
                         "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 ()
+  (let* ((s "foo")
+         (bit-vector #*11001100)
+         (values `(nil 1 2 "test"
+                       ;; Floats duplicated here to ensure we get newly created instances
+                       (read-from-string "1.1") (read-from-string "1.2d0")
+                       (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))))
+    ;; 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))
-- 
1.7.10.4