additional list seeking transformations

 * Implement TRANSFORM-LIST-PRED-SEEK, very much akin to
   TRANSFORM-LIST-ITEM-SEEK, and use it to optimize MEMBER-IF[-NOT],
   ASSOC-IF[-NOT], and RASSOC-IF[-NOT].

 * Implement full versions of list seeking functions in terms of the
   specialized versions: in some cases this is a win, in some cases a
   loss -- but the number of places where functionality is duplicated
   is reduced, which should be easier on the maintenance and less
   bug-prone.

 * Add a TRANSFORM-LIST-ITEM-SEEK transform for RASSOC.

 * LVAR-FOR-NAMED-FUNCTION was a restricted form of LVAR-FUN-IS.  Do
   away with the former, and move the latter to ir1util.lisp.

diff --git a/NEWS b/NEWS
index 63f1842..b95aa43 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -4,6 +4,9 @@ changes in sbcl-1.0.20 relative to 1.0.19:
     SB-C::STACK-ALLOCATE-DYNAMIC-EXTENT, SB-C::STACK-ALLOCATE-VECTOR,
     and SB-C::STACK-ALLOCATE-VALUE-CELLS no longer exist. See documentation
     and SB-EXT:*STACK-ALLOCATE-DYNAMIC-EXTENT* for details.
     SB-C::STACK-ALLOCATE-DYNAMIC-EXTENT, SB-C::STACK-ALLOCATE-VECTOR,
     and SB-C::STACK-ALLOCATE-VALUE-CELLS no longer exist. See documentation
     and SB-EXT:*STACK-ALLOCATE-DYNAMIC-EXTENT* for details.

+  * 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: runtime lookup of function definitions can be
     elided in more cases, eg: (let ((x 'foo)) (funcall foo)).
   * bug fix: fixed #427: unused local aliens no longer cause compiler
   * optimization: runtime lookup of function definitions can be
     elided in more cases, eg: (let ((x 'foo)) (funcall foo)).
   * bug fix: fixed #427: unused local aliens no longer cause compiler

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 0a3357c..d612db1 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1185,6 +1185,10 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "%ARRAY-FILL-POINTER-P" "%ARRAY-RANK"
                "%ASSOC"
                "%ASSOC-EQ"
                "%ARRAY-FILL-POINTER-P" "%ARRAY-RANK"
                "%ASSOC"
                "%ASSOC-EQ"

+               "%ASSOC-IF"
+               "%ASSOC-IF-KEY"
+               "%ASSOC-IF-NOT"
+               "%ASSOC-IF-NOT-KEY"

                "%ASSOC-KEY"
                "%ASSOC-KEY-EQ"
                "%ASSOC-KEY-TEST"
                "%ASSOC-KEY"
                "%ASSOC-KEY-EQ"
                "%ASSOC-KEY-TEST"

@@ -1230,6 +1234,10 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "%MASK-FIELD"
                "%MEMBER"
                "%MEMBER-EQ"
                "%MASK-FIELD"
                "%MEMBER"
                "%MEMBER-EQ"

+               "%MEMBER-IF"
+               "%MEMBER-IF-KEY"
+               "%MEMBER-IF-NOT"
+               "%MEMBER-IF-NOT-KEY"

                "%MEMBER-KEY"
                "%MEMBER-KEY-EQ"
                "%MEMBER-KEY-TEST"
                "%MEMBER-KEY"
                "%MEMBER-KEY-EQ"
                "%MEMBER-KEY-TEST"

@@ -1237,6 +1245,18 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "%MEMBER-TEST"
                "%MEMBER-TEST-NOT"
                "%NEGATE" "%POW" "%PUTHASH"
                "%MEMBER-TEST"
                "%MEMBER-TEST-NOT"
                "%NEGATE" "%POW" "%PUTHASH"

+               "%RASSOC"
+               "%RASSOC-EQ"
+               "%RASSOC-IF"
+               "%RASSOC-IF-KEY"
+               "%RASSOC-IF-NOT"
+               "%RASSOC-IF-NOT-KEY"
+               "%RASSOC-KEY"
+               "%RASSOC-KEY-EQ"
+               "%RASSOC-KEY-TEST"
+               "%RASSOC-KEY-TEST-NOT"
+               "%RASSOC-TEST"
+               "%RASSOC-TEST-NOT"

                "%RAW-BITS" "%RAW-BITS-WITH-OFFSET" "%VECTOR-RAW-BITS"
                "%RAW-REF-COMPLEX-DOUBLE" "%RAW-REF-COMPLEX-LONG"
                "%RAW-REF-COMPLEX-SINGLE" "%RAW-REF-DOUBLE"
                "%RAW-BITS" "%RAW-BITS-WITH-OFFSET" "%VECTOR-RAW-BITS"
                "%RAW-REF-COMPLEX-DOUBLE" "%RAW-REF-COMPLEX-LONG"
                "%RAW-REF-COMPLEX-SINGLE" "%RAW-REF-DOUBLE"

diff --git a/src/code/list.lisp b/src/code/list.lisp
index 46cbb32..39af79e 100644 (file)
--- a/src/code/list.lisp
+++ b/src/code/list.lisp
@@ -19,10 +19,10 @@
 
 (declaim (maybe-inline
           tree-equal nth %setnth nthcdr make-list
 
 (declaim (maybe-inline
           tree-equal nth %setnth nthcdr make-list

-          member-if member-if-not tailp union
+          tailp union

           nunion intersection nintersection set-difference nset-difference
           set-exclusive-or nset-exclusive-or subsetp acons
           nunion intersection nintersection set-difference nset-difference
           set-exclusive-or nset-exclusive-or subsetp acons

-          assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if
+          subst subst-if

           subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis))
 
 ;;; These functions perform basic list operations.
           subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis))
 
 ;;; These functions perform basic list operations.

@@ -801,41 +801,45 @@
 \f
 ;;;; functions for using lists as sets
 
 \f
 ;;;; functions for using lists as sets
 

-(defun member (item list &key key (test #'eql testp) (test-not #'eql notp))
+(defun member (item list &key key (test nil testp) (test-not nil notp))

   #!+sb-doc
   "Return the tail of LIST beginning with first element satisfying EQLity,
    :TEST, or :TEST-NOT with the given ITEM."
   (when (and testp notp)
     (error ":TEST and :TEST-NOT were both supplied."))
   (let ((key (and key (%coerce-callable-to-fun key)))
   #!+sb-doc
   "Return the tail of LIST beginning with first element satisfying EQLity,
    :TEST, or :TEST-NOT with the given ITEM."
   (when (and testp notp)
     (error ":TEST and :TEST-NOT were both supplied."))
   (let ((key (and key (%coerce-callable-to-fun key)))

-        (test (if testp (%coerce-callable-to-fun test) test))
-        (test-not (if notp (%coerce-callable-to-fun test-not) test-not)))
-    (declare (type function test test-not))
-    (do ((list list (cdr list)))
-        ((null list) nil)
-      (let ((car (car list)))
-        (when (satisfies-the-test item car)
-          (return list))))))
+        (test (and testp (%coerce-callable-to-fun test)))
+        (test-not (and notp (%coerce-callable-to-fun test-not))))
+    (cond (test
+           (if key
+               (%member-key-test item list key test)
+               (%member-test item list test)))
+          (test-not
+           (if key
+               (%member-key-test-not item list key test-not)
+               (%member-test-not item list test-not)))
+          (t
+           (if key
+               (%member-key item list key)
+               (%member item list))))))

 
 (defun member-if (test list &key key)
   #!+sb-doc
   "Return tail of LIST beginning with first element satisfying TEST."
   (let ((test (%coerce-callable-to-fun test))
         (key (and key (%coerce-callable-to-fun key))))
 
 (defun member-if (test list &key key)
   #!+sb-doc
   "Return tail of LIST beginning with first element satisfying TEST."
   (let ((test (%coerce-callable-to-fun test))
         (key (and key (%coerce-callable-to-fun key))))

-    (do ((list list (cdr list)))
-        ((endp list) nil)
-      (if (funcall test (apply-key key (car list)))
-          (return list)))))
+    (if key
+        (%member-if-key test list key)
+        (%member-if test list))))

 
 (defun member-if-not (test list &key key)
   #!+sb-doc
   "Return tail of LIST beginning with first element not satisfying TEST."
   (let ((test (%coerce-callable-to-fun test))
         (key (and key (%coerce-callable-to-fun key))))
 
 (defun member-if-not (test list &key key)
   #!+sb-doc
   "Return tail of LIST beginning with first element not satisfying TEST."
   (let ((test (%coerce-callable-to-fun test))
         (key (and key (%coerce-callable-to-fun key))))

-    (do ((list list (cdr list)))
-        ((endp list) ())
-      (if (not (funcall test (apply-key key (car list))))
-          (return list)))))
+    (if key
+        (%member-if-not-key test list key)
+        (%member-if-not test list))))

 
 (defun tailp (object list)
   #!+sb-doc
 
 (defun tailp (object list)
   #!+sb-doc

@@ -851,13 +855,21 @@
   "Add ITEM to LIST unless it is already a member"
   (when (and testp notp)
     (error ":TEST and :TEST-NOT were both supplied."))
   "Add ITEM to LIST unless it is already a member"
   (when (and testp notp)
     (error ":TEST and :TEST-NOT were both supplied."))

-  (let ((key (and key (%coerce-callable-to-fun key))))
-    (if (let ((key-val (apply-key key item)))
-          (if notp
-              (member key-val list :test-not test-not :key key)
-              (member key-val list :test test :key key)))
-        list
-        (cons item list))))
+  (let ((key (and key (%coerce-callable-to-fun key)))
+        (test (and testp (%coerce-callable-to-fun test)))
+        (test-not (and notp (%coerce-callable-to-fun test-not))))
+    (cond (test
+           (if key
+               (%adjoin-key-test item list key test)
+               (%adjoin-test item list test)))
+          (test-not
+           (if key
+               (%adjoin-key-test-not item list key test-not)
+               (%adjoin-test-not item list test-not)))
+          (t
+           (if key
+               (%adjoin-key item list key)
+               (%adjoin item list))))))

 
 (defconstant +list-based-union-limit+ 80)
 
 
 (defconstant +list-based-union-limit+ 80)
 

@@ -1132,15 +1144,6 @@
         (error "The lists of keys and data are of unequal length."))
     (setq alist (acons (car x) (car y) alist))))
 
         (error "The lists of keys and data are of unequal length."))
     (setq alist (acons (car x) (car y) alist))))
 

-;;; This is defined in the run-time environment, not just the compile-time
-;;; environment (i.e. not wrapped in EVAL-WHEN (COMPILE EVAL)) because it
-;;; can appear in inline expansions.
-(defmacro assoc-guts (test-expr)
-  `(do ((alist alist (cdr alist)))
-       ((endp alist))
-    (when (and (car alist) ,test-expr)
-      (return (car alist)))))
-

 (defun assoc (item alist &key key (test nil testp) (test-not nil notp))
   #!+sb-doc
   "Return the cons in ALIST whose car is equal (by a given test or EQL) to
 (defun assoc (item alist &key key (test nil testp) (test-not nil notp))
   #!+sb-doc
   "Return the cons in ALIST whose car is equal (by a given test or EQL) to

@@ -1152,17 +1155,16 @@
         (test-not (and notp (%coerce-callable-to-fun test-not))))
     (cond (test
            (if key
         (test-not (and notp (%coerce-callable-to-fun test-not))))
     (cond (test
            (if key

-               (assoc-guts (funcall test item (funcall key (caar alist))))
-               (assoc-guts (funcall test item (caar alist)))))
+               (%assoc-key-test item alist key test)
+               (%assoc-test item alist test)))

           (test-not
            (if key
           (test-not
            (if key

-               (assoc-guts (not (funcall test-not item
-                                         (funcall key (caar alist)))))
-               (assoc-guts (not (funcall test-not item (caar alist))))))
+               (%assoc-key-test-not item alist key test-not)
+               (%assoc-test-not item alist test-not)))

           (t
            (if key
           (t
            (if key

-               (assoc-guts (eql item (funcall key (caar alist))))
-               (assoc-guts (eql item (caar alist))))))))
+               (%assoc-key item alist key)
+               (%assoc item alist))))))

 
 (defun assoc-if (predicate alist &key key)
   #!+sb-doc
 
 (defun assoc-if (predicate alist &key key)
   #!+sb-doc

@@ -1171,8 +1173,8 @@
   (let ((predicate (%coerce-callable-to-fun predicate))
         (key (and key (%coerce-callable-to-fun key))))
     (if key
   (let ((predicate (%coerce-callable-to-fun predicate))
         (key (and key (%coerce-callable-to-fun key))))
     (if key

-        (assoc-guts (funcall predicate (funcall key (caar alist))))
-        (assoc-guts (funcall predicate (caar alist))))))
+        (%assoc-if-key predicate alist key)
+        (%assoc-if predicate alist))))

 
 (defun assoc-if-not (predicate alist &key key)
   #!+sb-doc
 
 (defun assoc-if-not (predicate alist &key key)
   #!+sb-doc

@@ -1181,8 +1183,8 @@
   (let ((predicate (%coerce-callable-to-fun predicate))
         (key (and key (%coerce-callable-to-fun key))))
     (if key
   (let ((predicate (%coerce-callable-to-fun predicate))
         (key (and key (%coerce-callable-to-fun key))))
     (if key

-        (assoc-guts (not (funcall predicate (funcall key (caar alist)))))
-        (assoc-guts (not (funcall predicate (caar alist)))))))
+        (%assoc-if-not-key predicate alist key)
+        (%assoc-if-not predicate alist))))

 
 (defun rassoc (item alist &key key (test nil testp) (test-not nil notp))
   (declare (list alist))
 
 (defun rassoc (item alist &key key (test nil testp) (test-not nil notp))
   (declare (list alist))

@@ -1196,17 +1198,16 @@
         (test-not (and notp (%coerce-callable-to-fun test-not))))
     (cond (test
            (if key
         (test-not (and notp (%coerce-callable-to-fun test-not))))
     (cond (test
            (if key

-               (assoc-guts (funcall test item (funcall key (cdar alist))))
-               (assoc-guts (funcall test item (cdar alist)))))
+               (%rassoc-key-test item alist key test)
+               (%rassoc-test item alist test)))

           (test-not
            (if key
           (test-not
            (if key

-               (assoc-guts (not (funcall test-not item
-                                         (funcall key (cdar alist)))))
-               (assoc-guts (not (funcall test-not item (cdar alist))))))
+               (%rassoc-key-test-not item alist key test-not)
+               (%rassoc-test-not item alist test-not)))

           (t
            (if key
           (t
            (if key

-               (assoc-guts (eql item (funcall key (cdar alist))))
-               (assoc-guts (eql item (cdar alist))))))))
+               (%rassoc-key item alist key)
+               (%rassoc item alist))))))

 
 (defun rassoc-if (predicate alist &key key)
   #!+sb-doc
 
 (defun rassoc-if (predicate alist &key key)
   #!+sb-doc

@@ -1215,8 +1216,8 @@
   (let ((predicate (%coerce-callable-to-fun predicate))
         (key (and key (%coerce-callable-to-fun key))))
     (if key
   (let ((predicate (%coerce-callable-to-fun predicate))
         (key (and key (%coerce-callable-to-fun key))))
     (if key

-        (assoc-guts (funcall predicate (funcall key (cdar alist))))
-        (assoc-guts (funcall predicate (cdar alist))))))
+        (%rassoc-if-key predicate alist key)
+        (%rassoc-if predicate alist))))

 
 (defun rassoc-if-not (predicate alist &key key)
   #!+sb-doc
 
 (defun rassoc-if-not (predicate alist &key key)
   #!+sb-doc

@@ -1225,8 +1226,8 @@
   (let ((predicate (%coerce-callable-to-fun predicate))
         (key (and key (%coerce-callable-to-fun key))))
     (if key
   (let ((predicate (%coerce-callable-to-fun predicate))
         (key (and key (%coerce-callable-to-fun key))))
     (if key

-        (assoc-guts (not (funcall predicate (funcall key (cdar alist)))))
-        (assoc-guts (not (funcall predicate (cdar alist)))))))
+        (%rassoc-if-not-key predicate alist key)
+        (%rassoc-if-not predicate alist))))

 \f
 ;;;; mapping functions
 
 \f
 ;;;; mapping functions
 

@@ -1292,73 +1293,96 @@
 
 ;;;; Specialized versions
 
 
 ;;;; Specialized versions
 

-;;; %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.
+;;; %ADJOIN-*, %ASSOC-*, %MEMBER-*, and %RASSOC-* functions. Deftransforms
+;;; delegate to TRANSFORM-LIST-PRED-SEEK and TRANSFORM-LIST-ITEM-SEEK which
+;;; pick the appropriate versions. 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)
 (macrolet
     ((def (funs form &optional variant)

-       (flet ((%def (name)
+       (flet ((%def (name &optional conditional)

                 (let* ((body-loop
                         `(do ((list list (cdr list)))
                              ((null list) nil)
                            (declare (list list))
                            (let ((this (car list)))
                 (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 list))))
-                                     (adjoin
-                                      `(let ((target this))
-                                         (when ,form
-                                           (return t))))))))
+                             ,(let ((cxx (if (char= #\A (char (string name) 0))
+                                             'car    ; assoc, assoc-if, assoc-if-not
+                                             'cdr))) ; rassoc, rassoc-if, rassoc-if-not
+                                   (ecase name
+                                      ((assoc rassoc)
+                                       (if funs
+                                           `(when this
+                                              (let ((target (,cxx 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 (,cxx this)))
+                                              (when (and ,form this)
+                                                (return this)))))
+                                 ((assoc-if assoc-if-not rassoc-if rassoc-if-not)
+                                  (aver (equal '(eql x) (subseq form 0 2)))
+                                  `(when this
+                                     (let ((target (,cxx this)))
+                                       (,conditional (funcall ,@(cdr form))
+                                                     (return this)))))
+                                 (member
+                                  `(let ((target this))
+                                     (when ,form
+                                       (return list))))
+                                 ((member-if member-if-not)
+                                  (aver (equal '(eql x) (subseq form 0 2)))
+                                  `(let ((target this))
+                                     (,conditional (funcall ,@(cdr form))
+                                                   (return list))))
+                                 (adjoin
+                                  `(let ((target this))
+                                     (when ,form
+                                       (return t)))))))))

                        (body (if (eq 'adjoin name)
                                  `(if (let ,(when (member 'key funs)
                        (body (if (eq 'adjoin name)
                                  `(if (let ,(when (member 'key funs)

-                                                  `((item (funcall key item))))
+                                                  `((x (funcall key x))))

                                         ,body-loop)
                                       list
                                         ,body-loop)
                                       list

-                                      (cons item list))
+                                      (cons x list))

                                  body-loop)))
                   `(defun ,(intern (format nil "%~A~{-~A~}~@[-~A~]" name funs variant))
                                  body-loop)))
                   `(defun ,(intern (format nil "%~A~{-~A~}~@[-~A~]" name funs variant))

-                       (item list ,@funs)
+                       (x list ,@funs)

                      (declare (optimize speed (sb!c::verify-arg-count 0)))
                      ,@(when funs `((declare (function ,@funs))))
                      (declare (optimize speed (sb!c::verify-arg-count 0)))
                      ,@(when funs `((declare (function ,@funs))))

+                     ,@(unless (member name '(member assoc adjoin rassoc)) `((declare (function x))))

                      ,body))))
          `(progn
             ,(%def 'adjoin)
             ,(%def 'assoc)
                      ,body))))
          `(progn
             ,(%def 'adjoin)
             ,(%def 'assoc)

-            ,(%def 'member)))))
+            ,(%def 'member)
+            ,(%def 'rassoc)
+            ,@(when (and (not variant) (member funs '(() (key)) :test #'equal))
+                    (list (%def 'member-if 'when)
+                          (%def 'member-if-not 'unless)
+                          (%def 'assoc-if 'when)
+                          (%def 'assoc-if-not 'unless)
+                          (%def 'rassoc-if 'when)
+                          (%def 'rassoc-if-not 'unless)))))))

   (def ()
   (def ()

-      (eql item target))
+      (eql x target))

   (def ()
   (def ()

-      (eq item target)
+      (eq x target)

     eq)
   (def (key)
     eq)
   (def (key)

-      (eql item (funcall key target)))
+      (eql x (funcall key target)))

   (def (key)
   (def (key)

-      (eq item (funcall key target))
+      (eq x (funcall key target))

     eq)
   (def (key test)
     eq)
   (def (key test)

-      (funcall test item (funcall key target)))
+      (funcall test x (funcall key target)))

   (def (key test-not)
   (def (key test-not)

-      (not (funcall test-not item (funcall key target))))
+      (not (funcall test-not x (funcall key target))))

   (def (test)
   (def (test)

-      (funcall test item target))
+      (funcall test x target))

   (def (test-not)
   (def (test-not)

-      (not (funcall test-not item target))))
+      (not (funcall test-not x target))))

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 2beb884..99e2ef8 100644 (file)
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -1926,14 +1926,14 @@
                (setf (block-reoptimize (node-block node)) t)
                (reoptimize-component (node-component node) :maybe)))))))
 
                (setf (block-reoptimize (node-block node)) t)
                (reoptimize-component (node-component node) :maybe)))))))
 

-;;; True if LVAR is for 'NAME, or #'NAME (global, not local)
-(defun lvar-for-named-function (lvar name)
-  (if (constant-lvar-p lvar)
-      (eq name (lvar-value lvar))
-      (let ((use (lvar-uses lvar)))
-        (and (not (listp use))
-             (ref-p use)
-             (let ((leaf (ref-leaf use)))
-               (and (global-var-p leaf)
-                    (eq :global-function (global-var-kind leaf))
-                    (eq name (leaf-source-name leaf))))))))
+;;; Return true if LVAR's only use is a non-NOTINLINE reference to a
+;;; global function with one of the specified NAMES.
+(defun lvar-fun-is (lvar names)
+  (declare (type lvar lvar) (list names))
+  (let ((use (lvar-uses lvar)))
+    (and (ref-p use)
+         (let ((leaf (ref-leaf use)))
+           (and (global-var-p leaf)
+                (eq (global-var-kind leaf) :global-function)
+                (not (null (member (leaf-source-name leaf) names
+                                   :test #'equal))))))))

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 3277b04..eaf85fd 100644 (file)
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -291,7 +291,7 @@
              (or end length)
              (sequence-bounding-indices-bad-error vector start end)))))
 
              (or end length)
              (sequence-bounding-indices-bad-error vector start end)))))
 

-(defun specialized-list-seek-function-name (function-name key-functions variant)
+(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
                      ;; this ever so slightly faster then FORMAT, this
   (or (find-symbol (with-output-to-string (s)
                      ;; Write "%NAME-FUN1-FUN2-FUN3", etc. Not only is
                      ;; this ever so slightly faster then FORMAT, this

@@ -311,10 +311,10 @@
 
 (defun transform-list-item-seek (name item list key test test-not node)
   ;; If TEST is EQL, drop it.
 
 (defun transform-list-item-seek (name item list key test test-not node)
   ;; If TEST is EQL, drop it.

-  (when (and test (lvar-for-named-function test 'eql))
+  (when (and test (lvar-fun-is test '(eql)))

     (setf test nil))
   ;; Ditto for KEY IDENTITY.
     (setf test nil))
   ;; Ditto for KEY IDENTITY.

-  (when (and key (lvar-for-named-function key 'identity))
+  (when (and key (lvar-fun-is key '(identity)))

     (setf key nil))
   ;; Key can legally be NIL, but if it's NIL for sure we pretend it's
   ;; not there at all. If it might be NIL, make up a form to that
     (setf key nil))
   ;; Key can legally be NIL, but if it's NIL for sure we pretend it's
   ;; not there at all. If it might be NIL, make up a form to that

@@ -331,7 +331,7 @@
                                #'identity)))
                 (t
                  (values key '(%coerce-callable-to-fun key))))))
                                #'identity)))
                 (t
                  (values key '(%coerce-callable-to-fun key))))))

-    (let* ((c-test (cond ((and test (lvar-for-named-function test 'eq))
+    (let* ((c-test (cond ((and test (lvar-fun-is test '(eq)))

                           (setf test nil)
                           'eq)
                          ((and (not test) (not test-not))
                           (setf test nil)
                           'eq)
                          ((and (not test) (not test-not))

@@ -348,14 +348,15 @@
                  (when tail
                    `(if (let ((this ',(car tail)))
                           ,(ecase name
                  (when tail
                    `(if (let ((this ',(car tail)))
                           ,(ecase name

-                                  (assoc
-                                   `(and this (let ((target (car this)))
-                                                ,test-expr)))
+                                  ((assoc rassoc)
+                                   (let ((cxx (if (eq name 'assoc) 'car 'cdr)))
+                                     `(and this (let ((target (,cxx this)))
+                                                  ,test-expr))))

                                   (member
                                    `(let ((target this))
                                       ,test-expr))))
                         ',(ecase name
                                   (member
                                    `(let ((target this))
                                       ,test-expr))))
                         ',(ecase name

-                                 (assoc (car tail))
+                                 ((assoc rassoc) (car tail))

                                  (member tail))
                         ,(open-code (cdr tail)))))
                (ensure-fun (fun)
                                  (member tail))
                         ,(open-code (cdr tail)))))
                (ensure-fun (fun)

@@ -364,7 +365,7 @@
                      `(%coerce-callable-to-fun ,fun))))
         (let* ((cp (constant-lvar-p list))
                (c-list (when cp (lvar-value list))))
                      `(%coerce-callable-to-fun ,fun))))
         (let* ((cp (constant-lvar-p list))
                (c-list (when cp (lvar-value list))))

-          (cond ((and cp c-list (member name '(assoc member))
+          (cond ((and cp c-list (member name '(assoc rassoc member))

                       (policy node (>= speed space)))
                  `(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs)
                     ,(open-code c-list)))
                       (policy node (>= speed space)))
                  `(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs)
                     ,(open-code c-list)))

@@ -378,14 +379,77 @@
                  `(,(specialized-list-seek-function-name name funs c-test)
                     item list ,@(mapcar #'ensure-fun funs)))))))))
 
                  `(,(specialized-list-seek-function-name name funs c-test)
                     item list ,@(mapcar #'ensure-fun funs)))))))))
 

-(deftransform member ((item list &key key test test-not) * * :node node)
-  (transform-list-item-seek 'member item list key test test-not node))
-
-(deftransform assoc ((item list &key key test test-not) * * :node node)
-  (transform-list-item-seek 'assoc item list key test test-not node))
+(defun transform-list-pred-seek (name pred list key node)
+  ;; If KEY is IDENTITY, drop it.
+  (when (and key (lvar-fun-is key '(identity)))
+    (setf key nil))
+  ;; Key can legally be NIL, but if it's NIL for sure we pretend it's
+  ;; not there at all. If it might be NIL, make up a form to that
+  ;; ensures it is a function.
+  (multiple-value-bind (key key-form)
+      (when key
+        (let ((key-type (lvar-type key))
+              (null-type (specifier-type 'null)))
+          (cond ((csubtypep key-type null-type)
+                 (values nil nil))
+                ((csubtypep null-type key-type)
+                 (values key '(if key
+                               (%coerce-callable-to-fun key)
+                               #'identity)))
+                (t
+                 (values key '(%coerce-callable-to-fun 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))))
+      (when (member name '(member-if-not assoc-if-not rassoc-if-not))
+        (setf test-expr `(not ,test-expr)))
+      (labels ((open-code (tail)
+                 (when tail
+                   `(if (let ((this ',(car tail)))
+                          ,(ecase name
+                                  ((assoc-if assoc-if-not rassoc-if rassoc-if-not)
+                                   (let ((cxx (if (member name '(assoc-if assoc-if-not)) 'car 'cdr)))
+                                     `(and this (let ((target (,cxx this)))
+                                                  ,test-expr))))
+                                  ((member-if member-if-not)
+                                   `(let ((target this))
+                                      ,test-expr))))
+                        ',(ecase name
+                                 ((assoc-if assoc-if-not rassoc-if rassoc-if-not)
+                                  (car tail))
+                                 ((member-if member-if-not)
+                                  tail))
+                        ,(open-code (cdr tail))))))
+        (let* ((cp (constant-lvar-p list))
+               (c-list (when cp (lvar-value list))))
+          (cond ((and cp c-list (policy node (>= speed space)))
+                 `(let ((pred ,pred-expr)
+                        ,@(when key `((key ,key-form))))
+                    ,(open-code c-list)))
+                ((and cp (not c-list))
+                 ;; constant nil list -- nothing to find!
+                 nil)
+                (t
+                 ;; specialized out-of-line version
+                 `(,(specialized-list-seek-function-name name (when key '(key)))
+                    ,pred-expr list ,@(when key (list key-form))))))))))

 
 

-(deftransform adjoin ((item list &key key test test-not) * * :node node)
-  (transform-list-item-seek 'adjoin item list key test test-not node))
+(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))))))))
+  (def adjoin)
+  (def assoc  t)
+  (def member t)
+  (def rassoc t))

 
 (deftransform memq ((item list) (t (constant-arg list)))
   (labels ((rec (tail)
 
 (deftransform memq ((item list) (t (constant-arg list)))
   (labels ((rec (tail)

@@ -471,18 +535,6 @@
 \f
 ;;;; utilities
 
 \f
 ;;;; utilities
 

-;;; Return true if LVAR's only use is a non-NOTINLINE reference to a
-;;; global function with one of the specified NAMES.
-(defun lvar-fun-is (lvar names)
-  (declare (type lvar lvar) (list names))
-  (let ((use (lvar-uses lvar)))
-    (and (ref-p use)
-         (let ((leaf (ref-leaf use)))
-           (and (global-var-p leaf)
-                (eq (global-var-kind leaf) :global-function)
-                (not (null (member (leaf-source-name leaf) names
-                                   :test #'equal))))))))
-

 ;;; If LVAR is a constant lvar, the return the constant value. If it
 ;;; is null, then return default, otherwise quietly give up the IR1
 ;;; transform.
 ;;; If LVAR is a constant lvar, the return the constant value. If it
 ;;; is null, then return default, otherwise quietly give up the IR1
 ;;; transform.

diff --git a/tests/list.pure.lisp b/tests/list.pure.lisp
index d42a879..d9b06b2 100644 (file)
--- a/tests/list.pure.lisp
+++ b/tests/list.pure.lisp
@@ -183,7 +183,6 @@
     (test nil (member -1.0 numbers :key #'- :test 'eql))))
 
 ;;; assoc
     (test nil (member -1.0 numbers :key #'- :test 'eql))))
 
 ;;; assoc

-

 (macrolet ((test  (expected form)
              (let ((numbers '((1 a) (2 b)))
                    (tricky '(nil (a . b) nil (nil . c) (c . d))))
 (macrolet ((test  (expected form)
              (let ((numbers '((1 a) (2 b)))
                    (tricky '(nil (a . b) nil (nil . c) (c . d))))

@@ -229,6 +228,96 @@
     ;; alist
     (test (nil . c) (assoc nil tricky :test #'eq))))
 
     ;; alist
     (test (nil . c) (assoc nil tricky :test #'eq))))
 

+;;; rassoc
+(macrolet ((test  (expected form)
+             (let ((numbers '((a . 1) (b . 2)))
+                   (tricky '(nil (b . a) nil (c . nil) (d . c))))
+               `(progn
+                  (assert (equal ',expected (let ((numbers ',numbers)
+                                                  (tricky ',tricky))
+                                              (funcall fun ,@(cdr form)))))
+                  (assert (equal ',expected (funcall (lambda ()
+                                                       (declare (optimize speed))
+                                                       (let ((numbers ',numbers)
+                                                             (tricky ',tricky))
+                                                         ,form)))))
+                  (assert (equal ',expected (funcall (lambda ()
+                                                       (declare (optimize space))
+                                                       (let ((numbers ',numbers)
+                                                             (tricky ',tricky))
+                                                        ,form)))))))))
+  (let ((fun (car (list 'rassoc))))
+    (test (a . 1) (rassoc 1 numbers))
+    (test (b . 2) (rassoc 2 numbers))
+    (test (a . 1) (rassoc 1 numbers :key 'identity))
+    (test (b . 2) (rassoc 2 numbers :key #'identity))
+    (test nil (rassoc 1.0 numbers))
+
+    (test (a . 1) (rassoc 1.0 numbers :test #'=))
+    (test (a . 1) (rassoc 1.0 numbers :test #'= :key nil))
+    (test (b . 2) (rassoc 2.0 numbers :test '=))
+    (test nil (rassoc 0 numbers :test '=))
+
+    (test (a . 1) (rassoc 0 numbers :test-not #'>))
+    (test (b . 2) (rassoc 1 numbers :test-not 'eql))
+    (test nil (rassoc 0 numbers :test-not '<))
+
+    (test (a . 1) (rassoc -1 numbers :key #'-))
+    (test (b . 2) (rassoc -2 numbers :key '-))
+    (test nil (rassoc -1.0 numbers :key #'-))
+
+    (test (a . 1) (rassoc -1.0 numbers :key #'- :test '=))
+    (test (b . 2) (rassoc -2.0 numbers :key #'- :test '=))
+    (test nil (rassoc -1.0 numbers :key #'- :test 'eql))
+
+    (test (c . nil) (rassoc nil tricky :test #'eq))))
+
+;;;; member-if & assoc-if & rassoc-if
+(macrolet ((test (value form)
+             `(let ((* ,value))
+                (assert (eval ,form))
+                (assert (funcall (compile nil (lambda () ,form)))))))
+  (test 'evenp
+        (equal '(2 3 4) (member-if * (list 1 2 3 4))))
+  (test 'evenp
+        (equal '(2 3 4) (locally (declare (optimize speed))
+                          (member-if * '(1 2 3 4)))))
+  (test 'evenp
+        (equal '(3 4) (member-if * (list 1 2 3 4) :key (lambda (x) (if (= 3 x) 2 1)))))
+  (test 'evenp
+        (equal '(2 :two) (assoc-if * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four)))))
+  (test 'evenp
+        (equal '(3 :three) (assoc-if * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four))
+                                   :key (lambda (x) (if (= 3 x) 2 1)))))
+  (test 'evenp
+        (equal '(:two . 2) (rassoc-if * (list '(:one . 1) '(:three . 3) '(:two . 2) '(:four . 4)))))
+  (test (list 1 2 3 4)
+        (equal '(2 3 4) (member-if 'evenp *)))
+  (test (list (cons 1 'a) (cons 2 'b) (cons 3 'c))
+        (equal (cons 2 'b) (assoc-if 'evenp *))))
+
+;;;; member-if-not & assoc-if-not
+(macrolet ((test (value form)
+             `(let ((* ,value))
+                (assert (eval ,form))
+                (assert (funcall (compile nil (lambda () ,form)))))))
+  (test 'oddp
+        (equal '(2 3 4) (member-if-not * (list 1 2 3 4))))
+  (test 'oddp
+        (equal '(2 3 4) (locally (declare (optimize speed))
+                          (member-if-not * '(1 2 3 4)))))
+  (test 'oddp
+        (equal '(3 4) (member-if-not * (list 1 2 3 4) :key (lambda (x) (if (= 3 x) 2 1)))))
+  (test 'oddp
+        (equal '(2 :two) (assoc-if-not * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four)))))
+  (test 'oddp
+        (equal '(3 :three) (assoc-if-not * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four))
+                                         :key (lambda (x) (if (= 3 x) 2 1)))))
+  (test (list 1 2 3 4)
+        (equal '(2 3 4) (member-if-not 'oddp *)))
+  (test (list (cons 1 'a) (cons 2 'b) (cons 3 'c))
+        (equal (cons 2 'b) (assoc-if-not 'oddp *))))
+

 ;;; bug reported by Dan Corkill: *PRINT-CASE* affected the compiler transforms
 ;;; for ASSOC & MEMBER
 (let ((*print-case* :downcase))
 ;;; bug reported by Dan Corkill: *PRINT-CASE* affected the compiler transforms
 ;;; for ASSOC & MEMBER
 (let ((*print-case* :downcase))

diff --git a/version.lisp-expr b/version.lisp-expr
index be72424..c6e291d 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".)
 ;;; 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.9"
+"1.0.19.10"