X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=3f70b073aacc2ce3afdc037cf9dcea5e64b799ce;hb=6bbc22725d3bf663726ed9adca544e39316364a6;hp=3efefa24a62364a9828743a7ef02a5ec2d9532d7;hpb=e0090a168ad00c8a13c2848e5608d74bf5217e6b;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 3efefa2..3f70b07 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -408,29 +408,44 @@ (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))) ;;;; utilities @@ -653,8 +668,10 @@ (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-BASH-COPY inline. "simple" is ;;; defined as those cases where we are doing word-aligned copies from @@ -719,7 +736,8 @@ (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) @@ -805,6 +823,8 @@ 'start) 'result 0 'size element-type) result)))) + ((csubtypep type (specifier-type 'string)) + '(string-subseq* seq start end)) (t '(vector-subseq* seq start end))))) @@ -816,15 +836,25 @@ ((and sequence (not vector) (not list)) t &optional t)) '(sb!sequence: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 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, @@ -1248,3 +1278,43 @@ (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)) +