From: Nikodemus Siivola Date: Thu, 19 Jul 2007 10:28:14 +0000 (+0000) Subject: 1.0.7.29: better ASSOC transform X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=423d7e5434081f8813e5c2399e4da052bcd36b57;p=sbcl.git 1.0.7.29: better ASSOC transform * Extend the new MEMBER optimizations to handle ASSOC as well, and define the corresponding %ASSOC[-KEY][-TEST][-NOT] functions as well. * Clean up the old ASSOC -> ASSQ and MEMBER -> MEMQ transforms that aren't firing anymore. * Tests. --- diff --git a/NEWS b/NEWS index 56332d4..ebd61fc 100644 --- a/NEWS +++ b/NEWS @@ -12,9 +12,10 @@ changes in sbcl-1.0.8 relative to sbcl-1.0.7: * optimization: slot definition lookup is now O(1). This speeds up eg. SLOT-VALUE and (SETF SLOT-VALUE) with variable slot names. * 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. + * optimization: ASSOC and MEMBER can now be open-coded for all + combinations of keyword arguments when second argument is constant + and SPEED >= SPACE. 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 a280fda..0dbc4d0 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1138,7 +1138,14 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%ACOSH" "%ARRAY-AVAILABLE-ELEMENTS" "%ARRAY-DATA-VECTOR" "%ARRAY-DIMENSION" "%ARRAY-DISPLACED-P" "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER" - "%ARRAY-FILL-POINTER-P" "%ARRAY-RANK" "%ASIN" "%ASINH" + "%ARRAY-FILL-POINTER-P" "%ARRAY-RANK" + "%ASSOC" + "%ASSOC-KEY" + "%ASSOC-KEY-TEST" + "%ASSOC-KEY-TEST-NOT" + "%ASSOC-TEST" + "%ASSOC-TEST-NOT" + "%ASIN" "%ASINH" "%ATAN" "%ATAN2" "%ATANH" "%CALLER-FRAME-AND-PC" "%CHECK-BOUND" "%CHECK-VECTOR-SEQUENCE-BOUNDS" "%CLOSURE-FUN" "%CLOSURE-INDEX-REF" diff --git a/src/code/list.lisp b/src/code/list.lisp index 7cedd81..a48af26 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -737,26 +737,6 @@ (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 "Return tail of LIST beginning with first element satisfying TEST." @@ -1177,3 +1157,43 @@ #!+sb-doc "Apply FUNCTION to successive CDRs of lists. Return NCONC of results." (map1 function (cons list more-lists) :nconc nil)) + +;;;; Specialized versions + +;;; %MEMBER-* and %ASSOC-* function. The transforms for %MEMBER and %ASSOC pick +;;; the appropriate version. These win because they have only positional arguments, +;;; the TEST & KEY functions are known to exist (or not), and are known to be +;;; functions, not function designators. +(macrolet ((def (funs form) + (flet ((%def (name) + `(defun ,(intern (format nil "%~A~{-~A~}" name funs)) + (item list ,@funs) + ,@(when funs `((declare (function ,@funs)))) + (do ((list list (cdr list))) + ((null list) nil) + (let ((this (car list))) + ,(ecase name + (assoc + `(when this + (let ((target (car this))) + (when (and this ,form) + (return this))))) + (member + `(let ((target this)) + (when ,form + (return list)))))))))) + `(progn + ,(%def 'member) + ,(%def 'assoc))))) + (def () + (eql item target)) + (def (key) + (eql item (funcall key target))) + (def (key test) + (funcall test item (funcall key target))) + (def (key test-not) + (not (funcall test-not item (funcall key target)))) + (def (test) + (funcall test item target)) + (def (test-not) + (not (funcall test-not item target)))) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index a9bde8f..2ddcdbc 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -291,8 +291,7 @@ (or end length) (sb!impl::signal-bounding-indices-bad-error vector start end))))) - -(deftransform member ((item list &key key test test-not) * * :node node) +(defun transform-list-item-seek (name list key test test-not 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. @@ -308,38 +307,29 @@ #'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"))) + (let* ((funs (remove nil (list (and key 'key) (cond (test 'test) + (test-not 'test-not))))) + (out-of-line (or (find-symbol (format nil "%~A~{-~A~}" name funs) + (load-time-value (find-package "SB!KERNEL"))) + (bug "Unknown list item seek transform: name=~S, funs=~S" + name funs))) + (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))) + (t `(eql item ,target-expr))))) (labels ((open-code (tail) (when tail - `(if (let ((car ',(car tail))) - ,test-expr) - ',tail + `(if (let ((this ',(car tail))) + ,(ecase name + (assoc + `(and this (let ((target (car this))) + ,test-expr))) + (member + `(let ((target this)) + ,test-expr)))) + ',(ecase name + (assoc (car tail)) + (member tail)) ,(open-code (cdr tail))))) (ensure-fun (fun) (if (eq 'key fun) @@ -350,6 +340,12 @@ ,(open-code (lvar-value list))) `(,out-of-line item list ,@(mapcar #'ensure-fun funs))))))) +(deftransform member ((item list &key key test test-not) * * :node node) + (transform-list-item-seek 'member list key test test-not node)) + +(deftransform assoc ((item list &key key test test-not) * * :node node) + (transform-list-item-seek 'assoc list key test test-not node)) + (deftransform memq ((item list) (t (constant-arg list))) (labels ((rec (tail) (if tail @@ -359,32 +355,28 @@ 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 -;;; this was done, a few bytes could be saved by a call to a shared -;;; function. This remains to be done. -(macrolet ((def (fun eq-fun) - `(deftransform ,fun ((item list &key test) (t list &rest t) *) - "convert to EQ test" - ;; FIXME: The scope of this transformation could be - ;; widened somewhat, letting it work whenever the test is - ;; 'EQL and we know from the type of ITEM that it #'EQ - ;; works like #'EQL on it. (E.g. types FIXNUM, CHARACTER, - ;; and SYMBOL.) - ;; If TEST is EQ, apply transform, else - ;; if test is not EQL, then give up on transform, else - ;; if ITEM is not a NUMBER or is a FIXNUM, apply - ;; transform, else give up on transform. - (cond (test - (unless (lvar-fun-is test '(eq)) - (give-up-ir1-transform))) - ((types-equal-or-intersect (lvar-type item) - (specifier-type 'number)) - (give-up-ir1-transform "Item might be a number."))) - `(,',eq-fun item list)))) - (def delete delq) - (def assoc assq) - (def member memq)) +;;; A similar transform used to apply to MEMBER and ASSOC, but since +;;; TRANSFORM-LIST-ITEM-SEEK now takes care of them those transform +;;; would never fire, and (%MEMBER-TEST ITEM LIST #'EQ) should be +;;; almost as fast as MEMQ. +(deftransform delete ((item list &key test) (t list &rest t) *) + "convert to EQ test" + ;; FIXME: The scope of this transformation could be + ;; widened somewhat, letting it work whenever the test is + ;; 'EQL and we know from the type of ITEM that it #'EQ + ;; works like #'EQL on it. (E.g. types FIXNUM, CHARACTER, + ;; and SYMBOL.) + ;; If TEST is EQ, apply transform, else + ;; if test is not EQL, then give up on transform, else + ;; if ITEM is not a NUMBER or is a FIXNUM, apply + ;; transform, else give up on transform. + (cond (test + (unless (lvar-fun-is test '(eq)) + (give-up-ir1-transform))) + ((types-equal-or-intersect (lvar-type item) + (specifier-type 'number)) + (give-up-ir1-transform "Item might be a number."))) + `(delq item list)) (deftransform delete-if ((pred list) (t list)) "open code" diff --git a/tests/list.pure.lisp b/tests/list.pure.lisp index 4e61a7c..8f251d4 100644 --- a/tests/list.pure.lisp +++ b/tests/list.pure.lisp @@ -130,13 +130,6 @@ (assert (null (butlast s (* 1440 most-positive-fixnum)))) (assert (null (nbutlast s (* 1440 most-positive-fixnum))))) -;;; Bug reported by Paul Dietz: ASSOC should ignore NIL elements in a -;;; alist -(let ((f (compile nil '(lambda (x) - (assoc x '(nil (a . b) nil (nil . c) (c . d)) - :test #'eq))))) - (assert (equal (funcall f 'nil) '(nil . c)))) - ;;; enforce lists in symbol-plist (let ((s (gensym)) (l (list 1 3 4))) @@ -151,32 +144,80 @@ (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)) + (assert (equal ,expected (let ((numbers '(1 2))) + (funcall fun ,@(cdr form))))) + (assert (equal ,expected (funcall (lambda () + (declare (optimize speed)) + (let ((numbers '(1 2))) + ,form))))) + (assert (equal ,expected (funcall (lambda () + (declare (optimize space)) + (let ((numbers '(1 2))) + ,form)))))))) + (let ((x-numbers '(1 2)) (fun (car (list 'member)))) - (test numbers (member 1 numbers)) - (test (cdr numbers) (member 2 numbers)) + (test x-numbers (member 1 numbers)) + (test (cdr x-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 x-numbers (member 1.0 numbers :test #'=)) + (test x-numbers (member 1.0 numbers :test #'= :key nil)) + (test (cdr x-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 x-numbers (member 0 numbers :test-not #'>)) + (test (cdr x-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 x-numbers (member -1 numbers :key #'-)) + (test (cdr x-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 x-numbers (member -1.0 numbers :key #'- :test '=)) + (test (cdr x-numbers) (member -2.0 numbers :key #'- :test '=)) (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)))) + `(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 'assoc)))) + (test (1 a) (assoc 1 numbers)) + (test (2 b) (assoc 2 numbers)) + (test nil (assoc 1.0 numbers)) + + (test (1 a) (assoc 1.0 numbers :test #'=)) + (test (1 a) (assoc 1.0 numbers :test #'= :key nil)) + (test (2 b) (assoc 2.0 numbers :test '=)) + (test nil (assoc 0 numbers :test '=)) + + (test (1 a) (assoc 0 numbers :test-not #'>)) + (test (2 b) (assoc 1 numbers :test-not 'eql)) + (test nil (assoc 0 numbers :test-not '<)) + + (test (1 a) (assoc -1 numbers :key #'-)) + (test (2 b) (assoc -2 numbers :key '-)) + (test nil (assoc -1.0 numbers :key #'-)) + + (test (1 a) (assoc -1.0 numbers :key #'- :test '=)) + (test (2 b) (assoc -2.0 numbers :key #'- :test '=)) + (test nil (assoc -1.0 numbers :key #'- :test 'eql)) + + ;; Bug reported by Paul Dietz: ASSOC should ignore NIL elements in a + ;; alist + (test (nil . c) (assoc nil tricky :test #'eq)))) diff --git a/version.lisp-expr b/version.lisp-expr index ac0b0ce..ee2190b 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.28" +"1.0.7.29"