1.0.16.13: use TRANSFORM-LIST-ITEM-SEEK for ADJOIN as well

 * Now that the freeze was cancelled, do this properly...

NEWS

@@ -1,5 +1,7 @@
 ;;;; -*- coding: utf-8; -*-
 changes in sbcl-1.0.17 relative to 1.0.16:
+  * optimization: ADJOIN and PUSHNEW are upto ~70% faster in normal
+    SPEED policies.
   * optimization: APPEND is upto ~10% faster in normal SPEED policies.
   * optimization: two argument forms of LAST are upto ~10% faster
     in normal SPEED policies.

package-data-list.lisp-expr

@@ -1159,7 +1159,16 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                  "SB!EXT" "SB!FASL" "SB!INT" "SB!SYS" "SB!GRAY")
       :reexport ("DEF!STRUCT" "DEF!MACRO")
       :export ("%ACOS"
-               "%ACOSH" "%ARRAY-AVAILABLE-ELEMENTS" "%ARRAY-DATA-VECTOR"
+               "%ACOSH"
+               "%ADJOIN"
+               "%ADJOIN-EQ"
+               "%ADJOIN-KEY"
+               "%ADJOIN-KEY-EQ"
+               "%ADJOIN-KEY-TEST"
+               "%ADJOIN-KEY-TEST-NOT"
+               "%ADJOIN-TEST"
+               "%ADJOIN-TEST-NOT"
+               "%ARRAY-AVAILABLE-ELEMENTS" "%ARRAY-DATA-VECTOR"
                "%ARRAY-DIMENSION" "%ARRAY-DISPLACED-P"
                "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER"
                "%ARRAY-FILL-POINTER-P" "%ARRAY-RANK"

src/code/list.lisp

@@ -18,7 +18,7 @@
 ;;;; -- WHN 20000127
 
 (declaim (maybe-inline
-          adjoin tree-equal nth %setnth nthcdr make-list
+          tree-equal nth %setnth nthcdr make-list
           member-if member-if-not tailp union
           nunion intersection nintersection set-difference nset-difference
           set-exclusive-or nset-exclusive-or subsetp acons
@@ -1290,44 +1290,58 @@
 
 ;;;; Specialized versions
 
-;;; %MEMBER-* and %ASSOC-* functions. The transforms for MEMBER and
-;;; ASSOC pick the appropriate version. These win because they have
-;;; only positional arguments, the TEST, TEST-NOT & KEY functions are
-;;; known to exist (or not), and are known to be functions instead of
-;;; function designators. We are also able to transform many common
-;;; cases to -EQ versions, which are substantially faster then EQL
-;;; using ones.
+;;; %ADJOIN-*, %ASSOC-*, and %MEMBER-* functions. Deftransforms
+;;; delegate to TRANSFORM-LIST-ITEM-SEEK which picks the appropriate
+;;; version. These win because they have only positional arguments,
+;;; the TEST, TEST-NOT & KEY functions are known to exist (or not),
+;;; and are known to be functions instead of function designators. We
+;;; are also able to transform many common cases to -EQ versions,
+;;; which are substantially faster then EQL using ones.
 (macrolet
     ((def (funs form &optional variant)
        (flet ((%def (name)
-                `(defun ,(intern (format nil "%~A~{-~A~}~@[-~A~]" name funs variant))
-                     (item list ,@funs)
-                   (declare (optimize speed))
-                   ,@(when funs `((declare (function ,@funs))))
-                   (do ((list list (cdr list)))
-                       ((null list) nil)
-                     (declare (list list))
-                     (let ((this (car list)))
-                       ,(ecase name
-                               (assoc
-                                (if funs
-                                    `(when this
-                                       (let ((target (car this)))
+                (let* ((body-loop
+                        `(do ((list list (cdr list)))
+                             ((null list) nil)
+                           (declare (list list))
+                           (let ((this (car list)))
+                             ,(ecase name
+                                     (assoc
+                                      (if funs
+                                          `(when this
+                                             (let ((target (car this)))
+                                               (when ,form
+                                                 (return this))))
+                                          ;; If there is no TEST/TEST-NOT or
+                                          ;; KEY, do the EQ/EQL test first,
+                                          ;; before checking for NIL.
+                                          `(let ((target (car this)))
+                                             (when (and ,form this)
+                                               (return this)))))
+                                     (member
+                                      `(let ((target this))
                                          (when ,form
-                                           (return this))))
-                                    ;; If there is no TEST/TEST-NOT or
-                                    ;; KEY, do the EQ/EQL test first,
-                                    ;; before checking for NIL.
-                                    `(let ((target (car this)))
-                                       (when (and ,form this)
-                                         (return this)))))
-                               (member
-                                `(let ((target this))
-                                   (when ,form
-                                     (return list))))))))))
+                                           (return list))))
+                                     (adjoin
+                                      `(let ((target this))
+                                         (when ,form
+                                           (return t))))))))
+                       (body (if (eq 'adjoin name)
+                                 `(if (let ,(when (member 'key funs)
+                                                  `((item (funcall key item))))
+                                        ,body-loop)
+                                      list
+                                      (cons item list))
+                                 body-loop)))
+                  `(defun ,(intern (format nil "%~A~{-~A~}~@[-~A~]" name funs variant))
+                       (item list ,@funs)
+                     (declare (optimize speed (sb!c::verify-arg-count 0)))
+                     ,@(when funs `((declare (function ,@funs))))
+                     ,body))))
          `(progn
-            ,(%def 'member)
-            ,(%def 'assoc)))))
+            ,(%def 'adjoin)
+            ,(%def 'assoc)
+            ,(%def 'member)))))
   (def ()
       (eql item target))
   (def ()
@@ -1345,4 +1359,4 @@
   (def (test)
       (funcall test item target))
   (def (test-not)
-    (not (funcall test-not item target))))
+      (not (funcall test-not item target))))

src/compiler/seqtran.lisp

@@ -381,6 +381,9 @@
 (deftransform assoc ((item list &key key test test-not) * * :node node)
   (transform-list-item-seek 'assoc item list key test test-not node))
 
+(deftransform adjoin ((item list &key key test test-not) * * :node node)
+  (transform-list-item-seek 'adjoin item list key test test-not node))
+
 (deftransform memq ((item list) (t (constant-arg list)))
   (labels ((rec (tail)
              (if tail

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.16.12"
+"1.0.16.13"