1.0.19.18: transform ADJOIN, ASSOC, MEMBER, and RASSOC to -EQ versions more often

 * Add transforms from %FOO and %FOO-KEY to %FOO-EQ and %FOO-KEY-EQ,
   so that propagated type information has a chance to work its magic.

diff --git a/NEWS b/NEWS
index 70c9be0..7db39be 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -7,6 +7,8 @@ changes in sbcl-1.0.20 relative to 1.0.19:
   * optimization: ASSOC-IF, ASSOC-IF-NOT, MEMBER-IF, MEMBER-IF-NOT,
     RASSOC, RASSOC-IF, and RASSOC-IF-NOT are now equally efficient
     as ASSOC and MEMEBER.
+  * optimization: calls to ASSOC, MEMBER, and RASSOC can be transformed
+    to more efficient EQ-comparison versions more often.
   * optimization: enhanced derivation of DOLIST iteration variable type
     for constant lists.
   * optimization: constant folding of simple (LIST ...) forms as DOLIST

diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index f657293..a7d9537 100644 (file)
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -1482,6 +1482,15 @@
   function
   (flushable foldable))
 
+(defknown %adjoin     (t list)          list (explicit-check foldable flushable))
+(defknown %adjoin-key (t list function) list (explicit-check foldable flushable call))
+(defknown %assoc      (t list)          list (explicit-check foldable flushable))
+(defknown %assoc-key  (t list function) list (explicit-check foldable flushable call))
+(defknown %member     (t list)          list (explicit-check foldable flushable))
+(defknown %member-key (t list function) list (explicit-check foldable flushable call))
+(defknown %rassoc     (t list)          list (explicit-check foldable flushable))
+(defknown %rassoc-key (t list function) list (explicit-check foldable flushable call))
+
 (defknown %check-vector-sequence-bounds (vector index sequence-end)
   index
   (unwind))

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index eaf85fd..7d5a935 100644 (file)
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -291,6 +291,13 @@
              (or end length)
              (sequence-bounding-indices-bad-error vector start end)))))
 
+(deftype eq-comparable-type ()
+  '(or fixnum (not number)))
+
+;;; True if EQL comparisons involving type can be simplified to EQ.
+(defun eq-comparable-type-p (type)
+  (csubtypep type (specifier-type 'eq-comparable-type)))
+
 (defun specialized-list-seek-function-name (function-name key-functions &optional variant)
   (or (find-symbol (with-output-to-string (s)
                      ;; Write "%NAME-FUN1-FUN2-FUN3", etc. Not only is
@@ -330,15 +337,16 @@
                                (%coerce-callable-to-fun key)
                                #'identity)))
                 (t
-                 (values key '(%coerce-callable-to-fun key))))))
+                 (values key (ensure-lvar-fun-form key 'key))))))
     (let* ((c-test (cond ((and test (lvar-fun-is test '(eq)))
                           (setf test nil)
                           'eq)
                          ((and (not test) (not test-not))
                           (when (eq-comparable-type-p (lvar-type item))
                             'eq))))
-           (funs (remove nil (list (and key 'key) (cond (test 'test)
-                                                        (test-not 'test-not)))))
+           (funs (delete nil (list (when key (list key 'key))
+                                   (when test (list test 'test))
+                                   (when test-not (list test-not 'test-not)))))
            (target-expr (if key '(%funcall key target) 'target))
            (test-expr (cond (test `(%funcall test item ,target-expr))
                             (test-not `(not (%funcall test-not item ,target-expr)))
@@ -359,15 +367,15 @@
                                  ((assoc rassoc) (car tail))
                                  (member tail))
                         ,(open-code (cdr tail)))))
-               (ensure-fun (fun)
-                 (if (eq 'key fun)
+               (ensure-fun (args)
+                 (if (eq 'key (second args))
                      key-form
-                     `(%coerce-callable-to-fun ,fun))))
+                     (apply #'ensure-lvar-fun-form args))))
         (let* ((cp (constant-lvar-p list))
                (c-list (when cp (lvar-value list))))
           (cond ((and cp c-list (member name '(assoc rassoc member))
                       (policy node (>= speed space)))
-                 `(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs)
+                 `(let ,(mapcar (lambda (fun) `(,(second fun) ,(ensure-fun fun))) funs)
                     ,(open-code c-list)))
                 ((and cp (not c-list))
                  ;; constant nil list
@@ -376,7 +384,7 @@
                      nil))
                 (t
                  ;; specialized out-of-line version
-                 `(,(specialized-list-seek-function-name name funs c-test)
+                 `(,(specialized-list-seek-function-name name (mapcar #'second funs) c-test)
                     item list ,@(mapcar #'ensure-fun funs)))))))))
 
 (defun transform-list-pred-seek (name pred list key node)
@@ -397,11 +405,9 @@
                                (%coerce-callable-to-fun key)
                                #'identity)))
                 (t
-                 (values key '(%coerce-callable-to-fun key))))))
+                 (values key (ensure-lvar-fun-form key 'key))))))
     (let ((test-expr `(%funcall pred ,(if key '(%funcall key target) 'target)))
-          (pred-expr (if (csubtypep (lvar-type pred) (specifier-type 'function))
-                         'pred
-                         '(%coerce-callable-to-fun pred))))
+          (pred-expr (ensure-lvar-fun-form pred 'pred)))
       (when (member name '(member-if-not assoc-if-not rassoc-if-not))
         (setf test-expr `(not ,test-expr)))
       (labels ((open-code (tail)
@@ -436,16 +442,24 @@
                     ,pred-expr list ,@(when key (list key-form))))))))))
 
 (macrolet ((def (name &optional if/if-not)
-             `(progn
-                (deftransform ,name ((item list &key key test test-not) * * :node node)
-                  (transform-list-item-seek ',name item list key test test-not node))
-                ,@(when if/if-not
-                   (let ((if-name (symbolicate name "-IF"))
-                         (if-not-name (symbolicate name "-IF-NOT")))
-                     `((deftransform ,if-name ((pred list &key key) * * :node node)
-                         (transform-list-pred-seek ',if-name pred list key node))
-                       (deftransform ,if-not-name ((pred list &key key) * * :node node)
-                         (transform-list-pred-seek ',if-not-name pred list key node))))))))
+             (let ((basic (symbolicate "%" name))
+                   (basic-eq (symbolicate "%" name "-EQ"))
+                   (basic-key (symbolicate "%" name "-KEY"))
+                   (basic-key-eq (symbolicate "%" name "-KEY-EQ")))
+               `(progn
+                  (deftransform ,name ((item list &key key test test-not) * * :node node)
+                    (transform-list-item-seek ',name item list key test test-not node))
+                  (deftransform ,basic ((item list) (eq-comparable-type t))
+                    `(,',basic-eq item list))
+                  (deftransform ,basic-key ((item list) (eq-comparable-type t))
+                    `(,',basic-key-eq item list))
+                  ,@(when if/if-not
+                          (let ((if-name (symbolicate name "-IF"))
+                                (if-not-name (symbolicate name "-IF-NOT")))
+                            `((deftransform ,if-name ((pred list &key key) * * :node node)
+                                (transform-list-pred-seek ',if-name pred list key node))
+                              (deftransform ,if-not-name ((pred list &key key) * * :node node)
+                                (transform-list-pred-seek ',if-not-name pred list key node)))))))))
   (def adjoin)
   (def assoc  t)
   (def member t)

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 231ce84..b17b404 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -3392,10 +3392,6 @@
   (def eq)
   (def char=))
 
-;;; True if EQL comparisons involving type can be simplified to EQ.
-(defun eq-comparable-type-p (type)
-  (csubtypep type (specifier-type '(or fixnum (not number)))))
-
 ;;; This is similar to SIMPLE-EQUALITY-TRANSFORM, except that we also
 ;;; try to convert to a type-specific predicate or EQ:
 ;;; -- If both args are characters, convert to CHAR=. This is better than

diff --git a/version.lisp-expr b/version.lisp-expr
index cefa092..d8136f2 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.19.17"
+"1.0.19.18"