From 5c52e958cbff33e64084bc165813c90ca0e39085 Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Thu, 5 Sep 2013 20:39:53 +0400 Subject: [PATCH] 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. --- NEWS | 4 +-- src/compiler/srctran.lisp | 84 ++++++++++++++++++++++++++++++++++----------- tests/compiler.pure.lisp | 62 ++++++++++++++++++++++----------- 3 files changed, 108 insertions(+), 42 deletions(-) diff --git a/NEWS b/NEWS index 1f9de42..0ec8409 100644 --- 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 --- 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 --- 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"))))) -- 1.7.10.4