(args-to-fn (if take-car `(car ,v) v))))
(let* ((fn-sym (gensym)) ; for ONCE-ONLY-ish purposes
- (call `(funcall ,fn-sym . ,(args-to-fn)))
+ (call `(%funcall ,fn-sym . ,(args-to-fn)))
(endtest `(or ,@(tests))))
- (ecase accumulate
- (:nconc
- (let ((temp (gensym))
- (map-result (gensym)))
- `(let ((,fn-sym ,fn)
- (,map-result (list nil)))
- (do-anonymous ((,temp ,map-result) . ,(do-clauses))
- (,endtest (cdr ,map-result))
- (setq ,temp (last (nconc ,temp ,call)))))))
- (:list
- (let ((temp (gensym))
- (map-result (gensym)))
- `(let ((,fn-sym ,fn)
- (,map-result (list nil)))
- (do-anonymous ((,temp ,map-result) . ,(do-clauses))
- (,endtest (truly-the list (cdr ,map-result)))
- (rplacd ,temp (setq ,temp (list ,call)))))))
- ((nil)
- `(let ((,fn-sym ,fn)
- (,n-first ,(first arglists)))
- (do-anonymous ,(do-clauses)
- (,endtest (truly-the list ,n-first))
- ,call))))))))
+
+ `(let ((,fn-sym (%coerce-callable-to-fun ,fn)))
+ ,(ecase accumulate
+ (:nconc
+ (let ((temp (gensym))
+ (map-result (gensym)))
+ `(let ((,map-result (list nil)))
+ (do-anonymous ((,temp ,map-result) . ,(do-clauses))
+ (,endtest (cdr ,map-result))
+ (setq ,temp (last (nconc ,temp ,call)))))))
+ (:list
+ (let ((temp (gensym))
+ (map-result (gensym)))
+ `(let ((,map-result (list nil)))
+ (do-anonymous ((,temp ,map-result) . ,(do-clauses))
+ (,endtest (truly-the list (cdr ,map-result)))
+ (rplacd ,temp (setq ,temp (list ,call)))))))
+ ((nil)
+ `(let ((,n-first ,(first arglists)))
+ (do-anonymous ,(do-clauses)
+ (,endtest (truly-the list ,n-first))
+ ,call)))))))))
(define-source-transform mapc (function list &rest more-lists)
(mapfoo-transform function (cons list more-lists) nil t))
(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 specialized-list-seek-function-name (function-name key-functions)
+ (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
+ ;; way we are also proof against *PRINT-CASE*
+ ;; frobbing and such.
+ (write-char #\% s)
+ (write-string (symbol-name function-name) s)
+ (dolist (f key-functions)
+ (write-char #\- s)
+ (write-string (symbol-name f) 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)
;; 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.
(cond ((csubtypep key-type null-type)
(values nil nil))
((csubtypep null-type key-type)
- (values key '(if key
+ (values key '(if key
(%coerce-callable-to-fun key)
#'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)))))
+ (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)
key-form
`(%coerce-callable-to-fun ,fun))))
- (if (and (constant-lvar-p list) (policy node (>= speed space)))
- `(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs)
- ,(open-code (lvar-value list)))
- `(,out-of-line item list ,@(mapcar #'ensure-fun funs)))))))
+ (let* ((cp (constant-lvar-p list))
+ (c-list (when cp (lvar-value list))))
+ (cond ((and cp c-list (policy node (>= speed space)))
+ `(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs)
+ ,(open-code c-list)))
+ ((and cp (not c-list))
+ ;; constant nil list -- nothing to find!
+ nil)
+ (t
+ ;; specialized out-of-line version
+ `(,(specialized-list-seek-function-name name funs)
+ 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)
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"