From 980efb1840028e646fc9206defb6b2da8decdff4 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 4 Aug 2008 10:33:54 +0000 Subject: [PATCH] 1.0.19.18: transform ADJOIN, ASSOC, MEMBER, and RASSOC to -EQ versions more often * Add transforms from %FOO and %FOO-KEY to %FOO-EQ and %FOO-KEY-EQ, so that propagated type information has a chance to work its magic. --- NEWS | 2 ++ src/compiler/fndb.lisp | 9 +++++++ src/compiler/seqtran.lisp | 58 ++++++++++++++++++++++++++++----------------- src/compiler/srctran.lisp | 4 ---- version.lisp-expr | 2 +- 5 files changed, 48 insertions(+), 27 deletions(-) diff --git a/NEWS b/NEWS index 70c9be0..7db39be 100644 --- a/NEWS +++ b/NEWS @@ -7,6 +7,8 @@ changes in sbcl-1.0.20 relative to 1.0.19: * 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: calls to ASSOC, MEMBER, and RASSOC can be transformed + to more efficient EQ-comparison versions more often. * optimization: enhanced derivation of DOLIST iteration variable type for constant lists. * optimization: constant folding of simple (LIST ...) forms as DOLIST diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index f657293..a7d9537 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1482,6 +1482,15 @@ function (flushable foldable)) +(defknown %adjoin (t list) list (explicit-check foldable flushable)) +(defknown %adjoin-key (t list function) list (explicit-check foldable flushable call)) +(defknown %assoc (t list) list (explicit-check foldable flushable)) +(defknown %assoc-key (t list function) list (explicit-check foldable flushable call)) +(defknown %member (t list) list (explicit-check foldable flushable)) +(defknown %member-key (t list function) list (explicit-check foldable flushable call)) +(defknown %rassoc (t list) list (explicit-check foldable flushable)) +(defknown %rassoc-key (t list function) list (explicit-check foldable flushable call)) + (defknown %check-vector-sequence-bounds (vector index sequence-end) index (unwind)) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index eaf85fd..7d5a935 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -291,6 +291,13 @@ (or end length) (sequence-bounding-indices-bad-error vector start end))))) +(deftype eq-comparable-type () + '(or fixnum (not number))) + +;;; True if EQL comparisons involving type can be simplified to EQ. +(defun eq-comparable-type-p (type) + (csubtypep type (specifier-type 'eq-comparable-type))) + (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 @@ -330,15 +337,16 @@ (%coerce-callable-to-fun key) #'identity))) (t - (values key '(%coerce-callable-to-fun key)))))) + (values key (ensure-lvar-fun-form key 'key)))))) (let* ((c-test (cond ((and test (lvar-fun-is 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))))) + (funs (delete nil (list (when key (list key 'key)) + (when test (list test 'test)) + (when test-not (list 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))) @@ -359,15 +367,15 @@ ((assoc rassoc) (car tail)) (member tail)) ,(open-code (cdr tail))))) - (ensure-fun (fun) - (if (eq 'key fun) + (ensure-fun (args) + (if (eq 'key (second args)) key-form - `(%coerce-callable-to-fun ,fun)))) + (apply #'ensure-lvar-fun-form args)))) (let* ((cp (constant-lvar-p list)) (c-list (when cp (lvar-value list)))) (cond ((and cp c-list (member name '(assoc rassoc member)) (policy node (>= speed space))) - `(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs) + `(let ,(mapcar (lambda (fun) `(,(second fun) ,(ensure-fun fun))) funs) ,(open-code c-list))) ((and cp (not c-list)) ;; constant nil list @@ -376,7 +384,7 @@ nil)) (t ;; specialized out-of-line version - `(,(specialized-list-seek-function-name name funs c-test) + `(,(specialized-list-seek-function-name name (mapcar #'second funs) c-test) item list ,@(mapcar #'ensure-fun funs))))))))) (defun transform-list-pred-seek (name pred list key node) @@ -397,11 +405,9 @@ (%coerce-callable-to-fun key) #'identity))) (t - (values key '(%coerce-callable-to-fun key)))))) + (values key (ensure-lvar-fun-form key '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)))) + (pred-expr (ensure-lvar-fun-form pred 'pred))) (when (member name '(member-if-not assoc-if-not rassoc-if-not)) (setf test-expr `(not ,test-expr))) (labels ((open-code (tail) @@ -436,16 +442,24 @@ ,pred-expr list ,@(when key (list key-form)))))))))) (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)))))))) + (let ((basic (symbolicate "%" name)) + (basic-eq (symbolicate "%" name "-EQ")) + (basic-key (symbolicate "%" name "-KEY")) + (basic-key-eq (symbolicate "%" name "-KEY-EQ"))) + `(progn + (deftransform ,name ((item list &key key test test-not) * * :node node) + (transform-list-item-seek ',name item list key test test-not node)) + (deftransform ,basic ((item list) (eq-comparable-type t)) + `(,',basic-eq item list)) + (deftransform ,basic-key ((item list) (eq-comparable-type t)) + `(,',basic-key-eq item list)) + ,@(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) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 231ce84..b17b404 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3392,10 +3392,6 @@ (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 diff --git a/version.lisp-expr b/version.lisp-expr index cefa092..d8136f2 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.19.17" +"1.0.19.18" -- 1.7.10.4