(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))
+ (setf 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
`(%coerce-callable-to-fun ,fun))))
(let* ((cp (constant-lvar-p list))
(c-list (when cp (lvar-value list))))
- (cond ((and cp c-list (policy node (>= speed space)))
+ (cond ((and cp c-list (member name '(assoc member))
+ (policy node (>= speed space)))
`(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs)
,(open-code c-list)))
((and cp (not c-list))
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 adjoin ((item list &key key test test-not) * * :node node)
+ (transform-list-item-seek 'adjoin item list key test test-not node))
(deftransform memq ((item list) (t (constant-arg list)))
(labels ((rec (tail)
(define-one-transform (sequence-type1 sequence-type2)
(make-replace-transform nil sequence-type1 sequence-type2)))
(define-replace-transforms)
- (define-one-transform simple-base-string (simple-array character (*)))
- (define-one-transform (simple-array character (*)) simple-base-string))
+ #!+sb-unicode
+ (progn
+ (define-one-transform (simple-array base-char (*)) (simple-array character (*)))
+ (define-one-transform (simple-array character (*)) (simple-array base-char (*)))))
;;; Expand simple cases of UB<SIZE>-BASH-COPY inline. "simple" is
;;; defined as those cases where we are doing word-aligned copies from
(do ((i end (1- i)))
((<= i ,src-word))
(setf (sb!kernel:%vector-raw-bits dst (1- i))
- (sb!kernel:%vector-raw-bits src (1- i)))))))))
+ (sb!kernel:%vector-raw-bits src (1- i))))
+ (values))))))
#.(loop for i = 1 then (* i 2)
collect `(deftransform ,(intern (format nil "UB~D-BASH-COPY" i)
(effective-find-position-key key))))))
(define-find-position-if-not find-if-not 0)
(define-find-position-if-not position-if-not 1))
+
+(macrolet ((define-trimmer-transform (fun-name leftp rightp)
+ `(deftransform ,fun-name ((char-bag string)
+ (t simple-string))
+ (let ((find-expr
+ (if (constant-lvar-p char-bag)
+ ;; If the bag is constant, use MEMBER
+ ;; instead of FIND, since we have a
+ ;; deftransform for MEMBER that can
+ ;; open-code all of the comparisons when
+ ;; the list is constant. -- JES, 2007-12-10
+ `(not (member (schar string index)
+ ',(coerce (lvar-value char-bag) 'list)
+ :test #'char=))
+ '(not (find (schar string index) char-bag :test #'char=)))))
+ `(flet ((char-not-in-bag (index)
+ ,find-expr))
+ (let* ((end (length string))
+ (left-end (if ,',leftp
+ (do ((index 0 (1+ index)))
+ ((or (= index (the fixnum end))
+ (char-not-in-bag index))
+ index)
+ (declare (fixnum index)))
+ 0))
+ (right-end (if ,',rightp
+ (do ((index (1- end) (1- index)))
+ ((or (< index left-end)
+ (char-not-in-bag index))
+ (1+ index))
+ (declare (fixnum index)))
+ end)))
+ (if (and (eql left-end 0)
+ (eql right-end (length string)))
+ string
+ (subseq string left-end right-end))))))))
+ (define-trimmer-transform string-left-trim t nil)
+ (define-trimmer-transform string-right-trim nil t)
+ (define-trimmer-transform string-trim t t))
+