+;;; However, we do not do this for elements whose size is < than the
+;;; word size because we don't want to deal with any alignment issues
+;;; inline. The UB*-BASH-COPY transforms might fix things up later
+;;; anyway.
+
+(defun maybe-expand-copy-loop-inline (src src-offset dst dst-offset length
+ element-type)
+ (let ((saetp (find-saetp element-type)))
+ (aver saetp)
+ (if (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-word-bits)
+ (expand-aref-copy-loop src src-offset dst dst-offset length)
+ `(locally (declare (optimize (safety 0)))
+ (replace ,dst ,src :start1 ,dst-offset :start2 ,src-offset :end1 ,length)))))
+
+(defun expand-aref-copy-loop (src src-offset dst dst-offset length)
+ (if (eql src-offset dst-offset)
+ `(do ((i (+ ,src-offset ,length) (1- i)))
+ ((<= i ,src-offset))
+ (declare (optimize (insert-array-bounds-checks 0)))
+ (setf (aref ,dst (1- i)) (aref ,src (1- i))))
+ ;; KLUDGE: The compiler is not able to derive that (+ offset
+ ;; length) must be a fixnum, but arrives at (unsigned-byte 29).
+ ;; We, however, know it must be so, as by this point the bounds
+ ;; have already been checked.
+ `(do ((i (truly-the fixnum (+ ,src-offset ,length)) (1- i))
+ (j (+ ,dst-offset ,length) (1- j)))
+ ((<= i ,src-offset))
+ (declare (optimize (insert-array-bounds-checks 0))
+ (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)
+ (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 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,
+;;; and enable even funkier transformations.
+(deftransform search ((pattern text &key (start1 0) (start2 0) end1 end2
+ (test #'eql)
+ (key #'identity)
+ from-end)
+ (vector vector &rest t)
+ *
+ :node node
+ :policy (> speed (max space safety)))
+ "open code"
+ (let ((from-end (when (lvar-p from-end)
+ (unless (constant-lvar-p from-end)
+ (give-up-ir1-transform ":FROM-END is not constant."))
+ (lvar-value from-end)))
+ (keyp (lvar-p key))
+ (testp (lvar-p test))
+ (check-bounds-p (policy node (plusp insert-array-bounds-checks))))
+ `(block search
+ (flet ((oops (vector start end)
+ (sequence-bounding-indices-bad-error vector start end)))
+ (let* ((len1 (length pattern))
+ (len2 (length text))
+ (end1 (or end1 len1))
+ (end2 (or end2 len2))
+ ,@(when keyp
+ '((key (coerce key 'function))))
+ ,@(when testp
+ '((test (coerce test 'function)))))
+ (declare (type index start1 start2 end1 end2))
+ ,@(when check-bounds-p
+ `((unless (<= start1 end1 len1)
+ (oops pattern start1 end1))
+ (unless (<= start2 end2 len2)
+ (oops pattern start2 end2))))
+ (do (,(if from-end
+ '(index2 (- end2 (- end1 start1)) (1- index2))
+ '(index2 start2 (1+ index2))))
+ (,(if from-end
+ '(< index2 start2)
+ '(>= index2 end2))
+ nil)
+ ;; INDEX2 is FIXNUM, not an INDEX, as right before the loop
+ ;; terminates is hits -1 when :FROM-END is true and :START2
+ ;; is 0.
+ (declare (type fixnum index2))
+ (when (do ((index1 start1 (1+ index1))
+ (index2 index2 (1+ index2)))
+ ((>= index1 end1) t)
+ (declare (type index index1 index2)
+ (optimize (insert-array-bounds-checks 0)))
+ ,@(unless from-end
+ '((when (= index2 end2)
+ (return-from search nil))))
+ (unless (,@(if testp
+ '(funcall test)
+ '(eql))
+ ,(if keyp
+ '(funcall key (aref pattern index1))
+ '(aref pattern index1))
+ ,(if keyp
+ '(funcall key (aref text index2))
+ '(aref text index2)))
+ (return nil)))
+ (return index2))))))))
+
+
+;;; Open-code CONCATENATE for strings. It would be possible to extend
+;;; this transform to non-strings, but I chose to just do the case that
+;;; should cover 95% of CONCATENATE performance complaints for now.
+;;; -- JES, 2007-11-17
+;;;
+;;; Only handle the simple result type cases. If somebody does (CONCATENATE
+;;; '(STRING 6) ...) their code won't be optimized, but nobody does that in
+;;; practice.
+;;;
+;;; Limit full open coding based on length of constant sequences. Default
+;;; value is chosen so that other parts of to compiler (constraint propagation
+;;; mainly) won't go nonlinear too badly. It's not an exact number -- but
+;;; in the right ballpark.
+(defvar *concatenate-open-code-limit* 129)
+
+(deftransform concatenate ((result-type &rest lvars)
+ ((constant-arg
+ (member string simple-string base-string simple-base-string))
+ &rest sequence)
+ * :node node)
+ (let ((vars (loop for x in lvars collect (gensym)))
+ (type (lvar-value result-type)))
+ (if (policy node (<= speed space))
+ ;; Out-of-line
+ `(lambda (.dummy. ,@vars)
+ (declare (ignore .dummy.))
+ ,(ecase type
+ ((string simple-string)
+ `(%concatenate-to-string ,@vars))
+ ((base-string simple-base-string)
+ `(%concatenate-to-base-string ,@vars))))
+ ;; Inline
+ (let* ((element-type (ecase type
+ ((string simple-string) 'character)
+ ((base-string simple-base-string) 'base-char)))
+ (lvar-values (loop for lvar in lvars
+ collect (when (constant-lvar-p lvar)
+ (lvar-value lvar))))
+ (lengths
+ (loop for value in lvar-values
+ for var in vars
+ collect (if value
+ (length value)
+ `(sb!impl::string-dispatch ((simple-array * (*))
+ sequence)
+ ,var
+ (declare (muffle-conditions compiler-note))
+ (length ,var))))))
+ `(apply
+ (lambda ,vars
+ (declare (ignorable ,@vars))
+ (declare (optimize (insert-array-bounds-checks 0)))
+ (let* ((.length. (+ ,@lengths))
+ (.pos. 0)
+ (.string. (make-string .length. :element-type ',element-type)))
+ (declare (type index .length. .pos.)
+ (muffle-conditions compiler-note))
+ ,@(loop for value in lvar-values
+ for var in vars
+ collect (if (and (stringp value)
+ (< (length value) *concatenate-open-code-limit*))
+ ;; Fold the array reads for constant arguments
+ `(progn
+ ,@(loop for c across value
+ for i from 0
+ collect
+ ;; Without truly-the we get massive numbers
+ ;; of pointless error traps.
+ `(setf (aref .string.
+ (truly-the index (+ .pos. ,i)))
+ ,c))
+ (incf .pos. ,(length value)))
+ `(sb!impl::string-dispatch
+ (#!+sb-unicode
+ (simple-array character (*))
+ (simple-array base-char (*))
+ t)
+ ,var
+ (replace .string. ,var :start1 .pos.)
+ (incf .pos. (length ,var)))))
+ .string.))
+ lvars)))))
+\f
+;;;; CONS accessor DERIVE-TYPE optimizers
+
+(defoptimizer (car derive-type) ((cons))
+ ;; This and CDR needs to use LVAR-CONSERVATIVE-TYPE because type inference
+ ;; gets confused by things like (SETF CAR).
+ (let ((type (lvar-conservative-type cons))
+ (null-type (specifier-type 'null)))
+ (cond ((eq type null-type)
+ null-type)
+ ((cons-type-p type)
+ (cons-type-car-type type)))))
+
+(defoptimizer (cdr derive-type) ((cons))
+ (let ((type (lvar-conservative-type cons))
+ (null-type (specifier-type 'null)))
+ (cond ((eq type null-type)
+ null-type)
+ ((cons-type-p type)
+ (cons-type-cdr-type type)))))
+\f
+;;;; FIND, POSITION, and their -IF and -IF-NOT variants
+
+;;; We want to make sure that %FIND-POSITION is inline-expanded into
+;;; %FIND-POSITION-IF only when %FIND-POSITION-IF has an inline
+;;; expansion, so we factor out the condition into this function.
+(defun check-inlineability-of-find-position-if (sequence from-end)
+ (let ((ctype (lvar-type sequence)))
+ (cond ((csubtypep ctype (specifier-type 'vector))
+ ;; It's not worth trying to inline vector code unless we
+ ;; know a fair amount about it at compile time.
+ (upgraded-element-type-specifier-or-give-up sequence)
+ (unless (constant-lvar-p from-end)
+ (give-up-ir1-transform
+ "FROM-END argument value not known at compile time")))
+ ((csubtypep ctype (specifier-type 'list))
+ ;; Inlining on lists is generally worthwhile.
+ )
+ (t
+ (give-up-ir1-transform
+ "sequence type not known at compile time")))))
+
+;;; %FIND-POSITION-IF and %FIND-POSITION-IF-NOT for LIST data
+(macrolet ((def (name condition)
+ `(deftransform ,name ((predicate sequence from-end start end key)
+ (function list t t t function)
+ *
+ :policy (> speed space))
+ "expand inline"
+ `(let ((find nil)
+ (position nil))
+ (flet ((bounds-error ()
+ (sequence-bounding-indices-bad-error sequence start end)))
+ (if (and end (> start end))
+ (bounds-error)
+ (do ((slow sequence (cdr slow))
+ (fast (cdr sequence) (cddr fast))
+ (index 0 (+ index 1)))
+ ((cond ((null slow)
+ (if (and end (> end index))
+ (bounds-error)
+ (return (values find position))))
+ ((and end (>= index end))
+ (return (values find position)))
+ ((eq slow fast)
+ (circular-list-error sequence)))
+ (bug "never"))
+ (declare (list slow fast))
+ (when (>= index start)
+ (let* ((element (car slow))
+ (key-i (funcall key element)))
+ (,',condition (funcall predicate key-i)
+ ;; This hack of dealing with non-NIL
+ ;; FROM-END for list data by iterating
+ ;; forward through the list and keeping
+ ;; track of the last time we found a
+ ;; match might be more screwy than what
+ ;; the user expects, but it seems to be
+ ;; allowed by the ANSI standard. (And
+ ;; if the user is screwy enough to ask
+ ;; for FROM-END behavior on list data,
+ ;; turnabout is fair play.)
+ ;;
+ ;; It's also not enormously efficient,
+ ;; calling PREDICATE and KEY more often
+ ;; than necessary; but all the
+ ;; alternatives seem to have their own
+ ;; efficiency problems.
+ (if from-end
+ (setf find element
+ position index)
+ (return (values element index)))))))))))))
+ (def %find-position-if when)
+ (def %find-position-if-not unless))
+
+;;; %FIND-POSITION for LIST data can be expanded into %FIND-POSITION-IF
+;;; without loss of efficiency. (I.e., the optimizer should be able
+;;; to straighten everything out.)
+(deftransform %find-position ((item sequence from-end start end key test)
+ (t list t t t t t)
+ *
+ :policy (> speed space))
+ "expand inline"
+ '(%find-position-if (let ((test-fun (%coerce-callable-to-fun test)))
+ ;; The order of arguments for asymmetric tests
+ ;; (e.g. #'<, as opposed to order-independent
+ ;; tests like #'=) is specified in the spec
+ ;; section 17.2.1 -- the O/Zi stuff there.
+ (lambda (i)
+ (funcall test-fun item i)))
+ sequence
+ from-end
+ start
+ end
+ (%coerce-callable-to-fun key)))
+
+;;; The inline expansions for the VECTOR case are saved as macros so
+;;; that we can share them between the DEFTRANSFORMs and the default
+;;; cases in the DEFUNs. (This isn't needed for the LIST case, because
+;;; the DEFTRANSFORMs for LIST are less choosy about when to expand.)
+(defun %find-position-or-find-position-if-vector-expansion (sequence-arg
+ from-end
+ start
+ end-arg
+ element
+ done-p-expr)
+ (with-unique-names (offset block index n-sequence sequence end)
+ `(let* ((,n-sequence ,sequence-arg))
+ (with-array-data ((,sequence ,n-sequence :offset-var ,offset)
+ (,start ,start)
+ (,end ,end-arg)
+ :check-fill-pointer t)
+ (block ,block
+ (macrolet ((maybe-return ()
+ ;; WITH-ARRAY-DATA has already performed bounds
+ ;; checking, so we can safely elide the checks
+ ;; in the inner loop.
+ '(let ((,element (locally (declare (optimize (insert-array-bounds-checks 0)))
+ (aref ,sequence ,index))))
+ (when ,done-p-expr
+ (return-from ,block
+ (values ,element
+ (- ,index ,offset)))))))
+ (if ,from-end
+ (loop for ,index
+ ;; (If we aren't fastidious about declaring that
+ ;; INDEX might be -1, then (FIND 1 #() :FROM-END T)
+ ;; can send us off into never-never land, since
+ ;; INDEX is initialized to -1.)
+ of-type index-or-minus-1
+ from (1- ,end) downto ,start do
+ (maybe-return))
+ (loop for ,index of-type index from ,start below ,end do
+ (maybe-return))))
+ (values nil nil))))))
+
+(def!macro %find-position-vector-macro (item sequence
+ from-end start end key test)
+ (with-unique-names (element)
+ (%find-position-or-find-position-if-vector-expansion
+ sequence
+ from-end
+ start
+ end
+ element
+ ;; (See the LIST transform for a discussion of the correct
+ ;; argument order, i.e. whether the searched-for ,ITEM goes before
+ ;; or after the checked sequence element.)
+ `(funcall ,test ,item (funcall ,key ,element)))))
+
+(def!macro %find-position-if-vector-macro (predicate sequence
+ from-end start end key)
+ (with-unique-names (element)
+ (%find-position-or-find-position-if-vector-expansion
+ sequence
+ from-end
+ start
+ end
+ element
+ `(funcall ,predicate (funcall ,key ,element)))))
+
+(def!macro %find-position-if-not-vector-macro (predicate sequence
+ from-end start end key)
+ (with-unique-names (element)
+ (%find-position-or-find-position-if-vector-expansion
+ sequence
+ from-end
+ start
+ end
+ element
+ `(not (funcall ,predicate (funcall ,key ,element))))))
+
+;;; %FIND-POSITION, %FIND-POSITION-IF and %FIND-POSITION-IF-NOT for
+;;; VECTOR data
+(deftransform %find-position-if ((predicate sequence from-end start end key)
+ (function vector t t t function)
+ *
+ :policy (> speed space))
+ "expand inline"
+ (check-inlineability-of-find-position-if sequence from-end)
+ '(%find-position-if-vector-macro predicate sequence
+ from-end start end key))
+
+(deftransform %find-position-if-not ((predicate sequence from-end start end key)
+ (function vector t t t function)
+ *
+ :policy (> speed space))
+ "expand inline"
+ (check-inlineability-of-find-position-if sequence from-end)
+ '(%find-position-if-not-vector-macro predicate sequence
+ from-end start end key))
+
+(deftransform %find-position ((item sequence from-end start end key test)
+ (t vector t t t function function)
+ *
+ :policy (> speed space))
+ "expand inline"
+ (check-inlineability-of-find-position-if sequence from-end)
+ '(%find-position-vector-macro item sequence
+ from-end start end key test))
+
+(deftransform %find-position ((item sequence from-end start end key test)
+ (character string t t t function function)
+ *
+ :policy (> speed space))
+ (if (eq '* (upgraded-element-type-specifier sequence))
+ (let ((form
+ `(sb!impl::string-dispatch ((simple-array character (*))
+ (simple-array base-char (*))
+ (simple-array nil (*)))
+ sequence
+ (%find-position item sequence from-end start end key test))))
+ (if (csubtypep (lvar-type sequence) (specifier-type 'simple-string))
+ form
+ ;; Otherwise we'd get three instances of WITH-ARRAY-DATA from
+ ;; %FIND-POSITION.
+ `(with-array-data ((sequence sequence :offset-var offset)
+ (start start)
+ (end end)
+ :check-fill-pointer t)
+ (multiple-value-bind (elt index) ,form
+ (values elt (when (fixnump index) (- index offset)))))))
+ ;; The type is known exactly, other transforms will take care of it.
+ (give-up-ir1-transform)))
+
+;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND,
+;;; POSITION-IF, etc.
+(define-source-transform effective-find-position-test (test test-not)
+ (once-only ((test test)
+ (test-not test-not))
+ `(cond
+ ((and ,test ,test-not)
+ (error "can't specify both :TEST and :TEST-NOT"))
+ (,test (%coerce-callable-to-fun ,test))
+ (,test-not
+ ;; (Without DYNAMIC-EXTENT, this is potentially horribly
+ ;; inefficient, but since the TEST-NOT option is deprecated
+ ;; anyway, we don't care.)
+ (complement (%coerce-callable-to-fun ,test-not)))
+ (t #'eql))))
+(define-source-transform effective-find-position-key (key)
+ (once-only ((key key))
+ `(if ,key
+ (%coerce-callable-to-fun ,key)
+ #'identity)))
+
+(macrolet ((define-find-position (fun-name values-index)
+ `(deftransform ,fun-name ((item sequence &key
+ from-end (start 0) end
+ key test test-not)
+ (t (or list vector) &rest t))
+ '(nth-value ,values-index
+ (%find-position item sequence
+ from-end start
+ end
+ (effective-find-position-key key)
+ (effective-find-position-test
+ test test-not))))))
+ (define-find-position find 0)
+ (define-find-position position 1))
+
+(macrolet ((define-find-position-if (fun-name values-index)
+ `(deftransform ,fun-name ((predicate sequence &key
+ from-end (start 0)
+ end key)
+ (t (or list vector) &rest t))
+ '(nth-value
+ ,values-index
+ (%find-position-if (%coerce-callable-to-fun predicate)
+ sequence from-end
+ start end
+ (effective-find-position-key key))))))
+ (define-find-position-if find-if 0)
+ (define-find-position-if position-if 1))
+
+;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT. We
+;;; didn't bother to worry about optimizing them, except note that on
+;;; Sat, Oct 06, 2001 at 04:22:38PM +0100, Christophe Rhodes wrote on
+;;; sbcl-devel
+;;;
+;;; My understanding is that while the :test-not argument is
+;;; deprecated in favour of :test (complement #'foo) because of
+;;; semantic difficulties (what happens if both :test and :test-not
+;;; are supplied, etc) the -if-not variants, while officially
+;;; deprecated, would be undeprecated were X3J13 actually to produce
+;;; a revised standard, as there are perfectly legitimate idiomatic
+;;; reasons for allowing the -if-not versions equal status,
+;;; particularly remove-if-not (== filter).
+;;;
+;;; This is only an informal understanding, I grant you, but
+;;; perhaps it's worth optimizing the -if-not versions in the same
+;;; way as the others?
+;;;
+;;; FIXME: Maybe remove uses of these deprecated functions within the
+;;; implementation of SBCL.
+(macrolet ((define-find-position-if-not (fun-name values-index)
+ `(deftransform ,fun-name ((predicate sequence &key
+ from-end (start 0)
+ end key)
+ (t (or list vector) &rest t))
+ '(nth-value
+ ,values-index
+ (%find-position-if-not (%coerce-callable-to-fun predicate)
+ sequence from-end
+ start end
+ (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))
+