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