* 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.
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.
"%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"
"%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"
(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))
;;;; 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)
(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))))))))
(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
(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
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)
(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
(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)
'(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)
;;; 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"
projects / sbcl.git / commitdiff