From 36717964ebcff8353035062789c08f223feccf1a Mon Sep 17 00:00:00 2001 From: Stas Boukarev 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