From ab6672fd5c392b8678681bdda138c4dc9e4de31a Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 3 Mar 2008 01:47:53 +0000 Subject: [PATCH] 1.0.15.9: further ASSOC & MEMBER transform improvements * Neither should be MAYBE-INLINE, as the DEFTRANSFORM result is better. * Compile the out-of-line bodies with high SPEED, and declare a missing LIST type. * Add %ASSOC-EQ, %ASSOC-KEY-EQ, and the corresponding %MEMBER- versions, and transform to these when (1) no :TEST is given, but the item to compare against is safe for EQ (2) :TEST is given and either 'EQ or #'EQ. --- NEWS | 3 +++ package-data-list.lisp-expr | 4 +++ src/code/list.lisp | 43 +++++++++++++++++++------------ src/compiler/ir1util.lisp | 12 +++++++++ src/compiler/seqtran.lisp | 60 +++++++++++++++++++++++++++---------------- src/compiler/srctran.lisp | 10 +++++--- version.lisp-expr | 2 +- 7 files changed, 90 insertions(+), 44 deletions(-) diff --git a/NEWS b/NEWS index 81fda56..49d208a 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,9 @@ changes in sbcl-1.0.16 relative to 1.0.15: * minor incompatible change: change PROBE-FILE back to returning NIL whenever we can't get a truename, as was the case before 1.0.14. + * optimization: MEMBER and ASSOC are over 50% faster for :TEST #'EQ + and cases where no :TEST is given but the compiler can infer that + the element to search is of type (OR FIXNUM (NOT NUMBER)). * bug fix: periodic polling was broken. (thanks to Espen S Johnsen) * bug fix: copying output from RUN-PROGRAM to a stream signalled bogus errors if select() was interrupted. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index f577d11..86fd959 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1164,7 +1164,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER" "%ARRAY-FILL-POINTER-P" "%ARRAY-RANK" "%ASSOC" + "%ASSOC-EQ" "%ASSOC-KEY" + "%ASSOC-KEY-EQ" "%ASSOC-KEY-TEST" "%ASSOC-KEY-TEST-NOT" "%ASSOC-TEST" @@ -1200,7 +1202,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%MAP-TO-NIL-ON-SIMPLE-VECTOR" "%MAP-TO-NIL-ON-VECTOR" "%MASK-FIELD" "%MEMBER" + "%MEMBER-EQ" "%MEMBER-KEY" + "%MEMBER-KEY-EQ" "%MEMBER-KEY-TEST" "%MEMBER-KEY-TEST-NOT" "%MEMBER-TEST" diff --git a/src/code/list.lisp b/src/code/list.lisp index 4a72e1a..f7537f3 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -19,9 +19,9 @@ (declaim (maybe-inline tree-equal nth %setnth nthcdr last last1 make-list append - nconc nconc2 member member-if member-if-not tailp adjoin union + nconc nconc2 member-if member-if-not tailp adjoin union nunion intersection nintersection set-difference nset-difference - set-exclusive-or nset-exclusive-or subsetp acons assoc + set-exclusive-or nset-exclusive-or subsetp acons assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis)) @@ -1217,35 +1217,44 @@ ;;;; 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) +;;; %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 &optional variant) (flet ((%def (name) - `(defun ,(intern (format nil "%~A~{-~A~}" name funs)) + `(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 - `(when this - (let ((target (car this))) - (when (and this ,form) - (return this))))) - (member - `(let ((target this)) - (when ,form - (return list)))))))))) + (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 () + (eq item target) + eq) (def (key) (eql item (funcall key target))) + (def (key) + (eq item (funcall key target)) + eq) (def (key test) (funcall test item (funcall key target))) (def (key test-not) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index f8091af..bd3c298 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1859,3 +1859,15 @@ (setf (node-reoptimize node) t) (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)))))))) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 3f70b07..494c047 100644 --- 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))))) -(defun specialized-list-seek-function-name (function-name key-functions) +(defun specialized-list-seek-function-name (function-name key-functions 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 @@ -301,32 +301,48 @@ (write-string (symbol-name function-name) s) (dolist (f key-functions) (write-char #\- s) - (write-string (symbol-name f) s))) + (write-string (symbol-name f) s)) + (when variant + (write-char #\- s) + (write-string (symbol-name variant) s))) (load-time-value (find-package "SB!KERNEL"))) - (bug "Unknown list item seek transform: name=~S, key-functions=~S" - function-name key-functions))) - -(defun transform-list-item-seek (name list key test test-not node) + (bug "Unknown list item seek transform: name=~S, key-functions=~S variant=~S" + function-name key-functions variant))) + +(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)) + (setf test nil)) + ;; Ditto for KEY IDENTITY. + (when (and key (lvar-for-named-function key 'identity)) + (set 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 - ;; ensure it is a function. + ;; ensures 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)))))) - (let* ((funs (remove nil (list (and key 'key) (cond (test 'test) + (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* ((c-test (cond ((and test (lvar-for-named-function test 'eq)) + (setf test nil) + 'eq) + ((and (not test) (not test-not)) + (when (eq-comparable-type-p (lvar-type item)) + 'eq)))) + (funs (remove nil (list (and key 'key) (cond (test 'test) (test-not 'test-not))))) (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))) + (c-test `(,c-test item ,target-expr)) (t `(eql item ,target-expr))))) (labels ((open-code (tail) (when tail @@ -356,14 +372,14 @@ nil) (t ;; specialized out-of-line version - `(,(specialized-list-seek-function-name name 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 list key test test-not 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 list key test test-not node)) + (transform-list-item-seek 'assoc item list key test test-not node)) (deftransform memq ((item list) (t (constant-arg list))) (labels ((rec (tail) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 9d5fb90..bdab82c 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3315,6 +3315,10 @@ (def eq) (def char=)) +;;; True if EQL comparisons involving type can be simplified to EQ. +(defun eq-comparable-type-p (type) + (csubtypep type (specifier-type '(or fixnum (not number))))) + ;;; This is similar to SIMPLE-EQUALITY-TRANSFORM, except that we also ;;; try to convert to a type-specific predicate or EQ: ;;; -- If both args are characters, convert to CHAR=. This is better than @@ -3335,9 +3339,7 @@ (let ((x-type (lvar-type x)) (y-type (lvar-type y)) (char-type (specifier-type 'character))) - (flet ((simple-type-p (type) - (csubtypep type (specifier-type '(or fixnum (not number))))) - (fixnum-type-p (type) + (flet ((fixnum-type-p (type) (csubtypep type (specifier-type 'fixnum)))) (cond ((same-leaf-ref-p x y) t) @@ -3348,7 +3350,7 @@ '(char= x y)) ((or (fixnum-type-p x-type) (fixnum-type-p y-type)) (commutative-arg-swap node)) - ((or (simple-type-p x-type) (simple-type-p y-type)) + ((or (eq-comparable-type-p x-type) (eq-comparable-type-p y-type)) '(eq x y)) ((and (not (constant-lvar-p y)) (or (constant-lvar-p x) diff --git a/version.lisp-expr b/version.lisp-expr index 8ab59e7..c1e2e85 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.15.8" +"1.0.15.9" -- 1.7.10.4