1.0.7.25: better MEMBER transform

 * Specialized versions for different keyword combinations: %MEMBER,
   %MEMBER-TEST, %MEMBER-KEY-TEST, etc. These versions have positional
   arguments, and the callable arguments are known to be functions.

 * The transform open codes for all combinations of keywords if the
   second argument is constant and (>= SPEED SPACE). Otherwise the
   transform selects the appropriate specialized version and open
   codes %COERCE-CALLABLE-TO-FUN around keyword arguments, allowing
   type inference to optimize it away for arguments known to be
   functions.

 * Tests.

diff --git a/NEWS b/NEWS
index 6c011bd..0609e7f 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -10,6 +10,9 @@ changes in sbcl-1.0.8 relative to sbcl-1.0.7:
   * performance bug fix: GETHASH and (SETF GETHASH) are once again
     non-consing.
   * optimization: STRING-TO-OCTETS is now up to 60% faster for UTF-8.
+  * optimization: MEMBER can now be open-coded for all combinations
+    of keyword arguments when second argument is constant, and in other
+    cases a specialized version is selected.
   * bug fix: using obsoleted structure instances with TYPEP and
     generic functions now signals a sensible error.
   * bug fix: threads waiting on GET-FOREGROUND can be interrupted.

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 3db36ee..a280fda 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1165,7 +1165,14 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "%MAP" "%MAP-TO-SIMPLE-VECTOR-ARITY-1"
                "%MAP-TO-LIST-ARITY-1" "%MAP-TO-NIL-ON-SEQUENCE"
                "%MAP-TO-NIL-ON-SIMPLE-VECTOR" "%MAP-TO-NIL-ON-VECTOR"
-               "%MASK-FIELD" "%NEGATE" "%POW" "%PUTHASH"
+               "%MASK-FIELD"
+               "%MEMBER"
+               "%MEMBER-KEY"
+               "%MEMBER-KEY-TEST"
+               "%MEMBER-KEY-TEST-NOT"
+               "%MEMBER-TEST"
+               "%MEMBER-TEST-NOT"
+               "%NEGATE" "%POW" "%PUTHASH"
                "%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 5f38f71..7cedd81 100644 (file)
--- a/src/code/list.lisp
+++ b/src/code/list.lisp
@@ -734,8 +734,28 @@
     (do ((list list (cdr list)))
         ((null list) nil)
       (let ((car (car list)))
-        (if (satisfies-the-test item car)
-            (return list))))))
+        (when (satisfies-the-test item car)
+          (return list))))))
+
+(macrolet ((def (name funs form)
+             `(defun ,name (item list ,@funs)
+                ,@(when funs `((declare (function ,@funs))))
+                (do ((list list (cdr list)))
+                    ((null list) nil)
+                  (when ,form
+                    (return list))))))
+  (def %member ()
+    (eql item (car list)))
+  (def %member-key (key)
+    (eql item (funcall key (car list))))
+  (def %member-key-test (key test)
+    (funcall test item (funcall key (car list))))
+  (def %member-key-test-not (key test-not)
+    (not (funcall test-not item (funcall key (car list)))))
+  (def %member-test (test)
+    (funcall test item (car list)))
+  (def %member-test-not (test-not)
+    (not (funcall test-not item (car list)))))
 
 (defun member-if (test list &key key)
   #!+sb-doc

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 62a3630..9258e7f 100644 (file)
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -292,28 +292,73 @@
             (or end length)
             (sb!impl::signal-bounding-indices-bad-error vector start end)))))
 
-(macrolet ((def (name)
-             `(deftransform ,name ((e l &key (test #'eql)) * *
-                                   :node node)
-                (unless (constant-lvar-p l)
-                  (give-up-ir1-transform))
-
-                (let ((val (lvar-value l)))
-                  (unless (policy node
-                                  (or (= speed 3)
-                                      (and (>= speed space)
-                                           (<= (length val) 5))))
-                    (give-up-ir1-transform))
-
-                  (labels ((frob (els)
-                             (if els
-                                 `(if (funcall test e ',(car els))
-                                      ',els
-                                      ,(frob (cdr els)))
-                                 nil)))
-                    (frob val))))))
-  (def member)
-  (def memq))
+
+(deftransform member ((item list &key key test test-not) * * :node node)
+  ;; 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
+  ;; ensure it is a function.
+  (multiple-value-bind (key key-form)
+      (if 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))))))
+    (multiple-value-bind (out-of-line funs test-expr)
+        (cond ((and (not key) (not test) (not test-not))
+               (values '%member
+                       '()
+                       '(eql item car)))
+              ((and key (not test) (not test-not))
+               (values '%member-key
+                       '(key)
+                       '(eql item (%funcall key car))))
+              ((and key test)
+               (values '%member-key-test
+                       '(key test)
+                       '(%funcall test item (%funcall key car))))
+              ((and key test-not)
+               (values '%member-key-test-not
+                       '(key test-not)
+                       '(not (%funcall test-not item (%funcall key car)))))
+              (test
+               (values '%member-test
+                       '(test)
+                       '(%funcall test item car)))
+              (test-not
+               (values '%member-test-not
+                       '(test-not)
+                       '(not (%funcall test item car))))
+              (t
+               (bug "never")))
+      (labels ((open-code (tail)
+                 (when tail
+                   `(if (let ((car ',(car tail)))
+                          ,test-expr)
+                        ',tail
+                        ,(open-code (cdr tail)))))
+               (ensure-fun (fun)
+                 (if (eq 'key fun)
+                     key-form
+                     `(%coerce-callable-to-fun ,fun))))
+        (if (and (constant-lvar-p list) (policy node (>= speed space)))
+            `(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs)
+               ,(open-code (lvar-value list)))
+            `(,out-of-line item list ,@(mapcar #'ensure-fun funs)))))))
+
+(deftransform memq ((item list) (t (constant-arg list)))
+  (labels ((rec (tail)
+             (if tail
+                 `(if (eq item ',(car tail))
+                      ',tail
+                      ,(rec (cdr tail)))
+                 nil)))
+    (rec (lvar-value list))))
 
 ;;; FIXME: We have rewritten the original code that used DOLIST to this
 ;;; more natural MACROLET.  However, the original code suggested that when

diff --git a/tests/list.pure.lisp b/tests/list.pure.lisp
index 50c3441..4e61a7c 100644 (file)
--- a/tests/list.pure.lisp
+++ b/tests/list.pure.lisp
@@ -146,3 +146,37 @@
       (ignore-errors (setf (symbol-plist s) (car l)))
     (assert (not res))
     (assert (typep err 'type-error))))
+
+;;; member
+
+(macrolet ((test  (expected form)
+             `(progn
+                (assert (eq ,expected (funcall fun ,@(cdr form))))
+                (assert (eq ,expected (funcall (lambda ()
+                                                 (declare (optimize speed))
+                                                 ,form))))
+                (assert (eq ,expected (funcall (lambda ()
+                                                 (declare (optimize space))
+                                                 ,form)))))))
+  (let ((numbers '(1 2))
+        (fun (car (list 'member))))
+    (test numbers (member 1 numbers))
+    (test (cdr numbers) (member 2 numbers))
+    (test nil (member 1.0 numbers ))
+
+    (test numbers (member 1.0 numbers :test #'=))
+    (test numbers (member 1.0 numbers :test #'= :key nil))
+    (test (cdr numbers) (member 2.0 numbers :test '=))
+    (test nil (member 0 numbers :test '=))
+
+    (test numbers (member 0 numbers :test-not #'>))
+    (test (cdr numbers) (member 1 numbers :test-not 'eql))
+    (test nil (member 0 numbers :test-not '<))
+
+    (test numbers (member -1 numbers :key #'-))
+    (test (cdr numbers) (member -2 numbers :key '-))
+    (test nil (member -1.0 numbers :key #'-))
+
+    (test numbers (member -1.0 numbers :key #'- :test '=))
+    (test (cdr numbers) (member -2.0 numbers :key #'- :test '=))
+    (test nil (member -1.0 numbers :key #'- :test 'eql))))

diff --git a/version.lisp-expr b/version.lisp-expr
index a940c83..a0068ef 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.7.24"
+"1.0.7.25"