From 1ac7e7c95d8badd4ff01d676dffece6b710cea13 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 17 Jul 2007 13:18:06 +0000 Subject: [PATCH] 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. --- NEWS | 3 ++ package-data-list.lisp-expr | 9 ++++- src/code/list.lisp | 24 +++++++++++- src/compiler/seqtran.lisp | 89 ++++++++++++++++++++++++++++++++++----------- tests/list.pure.lisp | 34 +++++++++++++++++ version.lisp-expr | 2 +- 6 files changed, 135 insertions(+), 26 deletions(-) diff --git a/NEWS b/NEWS index 6c011bd7e..0609e7fa2 100644 --- 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 3db36eeb1..a280fda3f 100644 --- 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 5f38f7126..7cedd8176 100644 --- 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 62a363098..9258e7f6d 100644 --- 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 50c3441e8..4e61a7cd6 100644 --- 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 a940c83c2..a0068ef5b 100644 --- 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" -- 2.11.4.GIT