(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)
(rplacd splice (cdr x))))
(t (setq splice x)))))
-(deftransform fill ((seq item &key (start 0) (end (length seq)))
- (vector t &key (:start t) (:end index))
+(deftransform fill ((seq item &key (start 0) (end nil))
+ (list t &key (:start t) (:end t)))
+ '(list-fill* seq item start end))
+
+(deftransform fill ((seq item &key (start 0) (end nil))
+ (vector t &key (:start t) (:end t))
*
- :policy (> speed space))
- "open code"
- (let ((element-type (upgraded-element-type-specifier-or-give-up seq)))
- (values
- `(with-array-data ((data seq)
- (start start)
- (end end)
- :check-fill-pointer t)
- (declare (type (simple-array ,element-type 1) data))
- (declare (type fixnum start end))
- (do ((i start (1+ i)))
- ((= i end) seq)
- (declare (type index i))
- ;; WITH-ARRAY-DATA did our range checks once and for all, so
- ;; it'd be wasteful to check again on every AREF...
- (declare (optimize (safety 0)))
- (setf (aref data i) item)))
- ;; ... though we still need to check that the new element can fit
- ;; into the vector in safe code. -- CSR, 2002-07-05
- `((declare (type ,element-type item))))))
+ :node node)
+ (let ((type (lvar-type seq))
+ (element-type (type-specifier (extract-upgraded-element-type seq))))
+ (cond ((and (neq '* element-type) (policy node (> speed space)))
+ (values
+ `(with-array-data ((data seq)
+ (start start)
+ (end end)
+ :check-fill-pointer t)
+ (declare (type (simple-array ,element-type 1) data))
+ (declare (type index start end))
+ ;; WITH-ARRAY-DATA did our range checks once and for all, so
+ ;; it'd be wasteful to check again on every AREF...
+ (declare (optimize (safety 0) (speed 3)))
+ (do ((i start (1+ i)))
+ ((= i end) seq)
+ (declare (type index i))
+ (setf (aref data i) item)))
+ ;; ... though we still need to check that the new element can fit
+ ;; into the vector in safe code. -- CSR, 2002-07-05
+ `((declare (type ,element-type item)))))
+ ((csubtypep type (specifier-type 'string))
+ '(string-fill* seq item start end))
+ (t
+ '(vector-fill* seq item start end)))))
+
+(deftransform fill ((seq item &key (start 0) (end nil))
+ ((and sequence (not vector) (not list)) t &key (:start t) (:end t)))
+ `(sb!sequence:fill seq item
+ :start start
+ :end (%check-generic-sequence-bounds seq start end)))
\f
;;;; utilities
(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)
(type (integer 0 #.sb!xc:array-dimension-limit) j i))
(setf (aref ,dst (1- j)) (aref ,src (1- i))))))
+;;; SUBSEQ, COPY-SEQ
+
(deftransform subseq ((seq start &optional end)
- ((or (simple-unboxed-array (*)) simple-vector) t &optional t)
- * :node node)
- (let ((array-type (lvar-type seq)))
- (unless (array-type-p array-type)
- (give-up-ir1-transform))
- (let ((element-type (type-specifier (array-type-specialized-element-type array-type))))
- `(let* ((length (length seq))
- (end (or end length)))
- ,(unless (policy node (= safety 0))
- '(progn
- (unless (<= 0 start end length)
- (sequence-bounding-indices-bad-error seq start end))))
- (let* ((size (- end start))
- (result (make-array size :element-type ',element-type)))
- ,(maybe-expand-copy-loop-inline 'seq (if (constant-lvar-p start)
- (lvar-value start)
- 'start)
- 'result 0 'size element-type)
- result)))))
+ (vector t &optional t)
+ *
+ :node node)
+ (let ((type (lvar-type seq)))
+ (cond
+ ((and (array-type-p type)
+ (csubtypep type (specifier-type '(or (simple-unboxed-array (*)) simple-vector))))
+ (let ((element-type (type-specifier (array-type-specialized-element-type type))))
+ `(let* ((length (length seq))
+ (end (or end length)))
+ ,(unless (policy node (zerop insert-array-bounds-checks))
+ '(progn
+ (unless (<= 0 start end length)
+ (sequence-bounding-indices-bad-error seq start end))))
+ (let* ((size (- end start))
+ (result (make-array size :element-type ',element-type)))
+ ,(maybe-expand-copy-loop-inline 'seq (if (constant-lvar-p start)
+ (lvar-value start)
+ 'start)
+ 'result 0 'size element-type)
+ result))))
+ ((csubtypep type (specifier-type 'string))
+ '(string-subseq* seq start end))
+ (t
+ '(vector-subseq* seq start end)))))
(deftransform subseq ((seq start &optional end)
(list t &optional t))
`(list-subseq* seq start end))
-(deftransform copy-seq ((seq) ((or (simple-unboxed-array (*)) simple-vector)) *)
- (let ((array-type (lvar-type seq)))
- (unless (array-type-p array-type)
- (give-up-ir1-transform))
- (let ((element-type (type-specifier (array-type-specialized-element-type array-type))))
- `(let* ((length (length seq))
- (result (make-array length :element-type ',element-type)))
- ,(maybe-expand-copy-loop-inline 'seq 0 'result 0 'length element-type)
- result))))
+(deftransform subseq ((seq start &optional end)
+ ((and sequence (not vector) (not list)) t &optional t))
+ '(sb!sequence:subseq seq start end))
+
+(deftransform copy-seq ((seq) (vector))
+ (let ((type (lvar-type seq)))
+ (cond ((and (array-type-p type)
+ (csubtypep type (specifier-type '(or (simple-unboxed-array (*)) simple-vector))))
+ (let ((element-type (type-specifier (array-type-specialized-element-type type))))
+ `(let* ((length (length seq))
+ (result (make-array length :element-type ',element-type)))
+ ,(maybe-expand-copy-loop-inline 'seq 0 'result 0 'length element-type)
+ result)))
+ ((csubtypep type (specifier-type 'string))
+ '(string-subseq* seq 0 nil))
+ (t
+ '(vector-subseq* seq 0 nil)))))
+
+(deftransform copy-seq ((seq) (list))
+ '(list-copy-seq* seq))
+
+(deftransform copy-seq ((seq) ((and sequence (not vector) (not list))))
+ '(sb!sequence:copy-seq seq))
;;; FIXME: it really should be possible to take advantage of the
;;; macros used in code/seq.lisp here to avoid duplication of code,
(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))
+
projects / sbcl.git / blobdiff