(logior res (ash bits (truly-the (integer 0 ,(- sb!vm:n-word-bits n-bits)) i))))))))
res)))))
(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))
- (declare (optimize (safety 0) (speed 3))
- (muffle-conditions compiler-note))
- (,basher ,bash-value data start (- end start))
- seq)
+ ;; KLUDGE: WITH-ARRAY data in its full glory is going to mess up
+ ;; dynamic-extent for MAKE-ARRAY :INITIAL-ELEMENT initialization.
+ (if (csubtypep (lvar-type seq) (specifier-type '(simple-array * (*))))
+ `(let* ((len (length seq))
+ (end (or end len))
+ (bound (1+ end)))
+ ;; Minor abuse %CHECK-BOUND for bounds checking.
+ ;; (- END START) may still end up negative, but
+ ;; the basher handle that.
+ (,basher ,bash-value seq
+ (%check-bound seq bound start)
+ (- (if end (%check-bound seq bound end) len)
+ start)))
+ `(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))
+ (declare (optimize (safety 0) (speed 3)))
+ (,basher ,bash-value data start (- end start))
+ seq))
`((declare (type ,element-type item))))))
((policy node (> speed space))
(values
(let ((type (lvar-type seq)))
(cond
((and (array-type-p type)
- (csubtypep type (specifier-type '(or (simple-unboxed-array (*)) simple-vector))))
+ (csubtypep type (specifier-type '(or (simple-unboxed-array (*)) simple-vector)))
+ (policy node (> speed space)))
(let ((element-type (type-specifier (array-type-specialized-element-type type))))
`(let* ((length (length seq))
(end (or end length)))
'start)
'result 0 'size element-type)
result))))
- ((csubtypep type (specifier-type 'string))
- '(string-subseq* seq start end))
(t
'(vector-subseq* seq start end)))))
(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)))))
(oops pattern start1 end1))
(unless (<= start2 end2 len2)
(oops pattern start2 end2))))
- (when (= 0 end1)
- (return-from search 0))
+ (when (= end1 start1)
+ (return-from search (if from-end
+ end2
+ start2)))
(do (,(if from-end
'(index2 (- end2 (- end1 start1)) (1- index2))
'(index2 start2 (1+ index2))))
;;; practice.
;;;
;;; Limit full open coding based on length of constant sequences. Default
-;;; value is chosen so that other parts of to compiler (constraint propagation
+;;; value is chosen so that other parts of the 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)
from-end start end key test))
(deftransform %find-position ((item sequence from-end start end key test)
+ (t bit-vector t t t t t)
+ * :node node)
+ (when (and test (lvar-fun-is test '(eq eql equal)))
+ (setf test nil))
+ (when (and key (lvar-fun-is key '(identity)))
+ (setf key nil))
+ (when (or test key)
+ (delay-ir1-transform node :optimize)
+ (give-up-ir1-transform "non-trivial :KEY or :TEST"))
+ (catch 'not-a-bit
+ `(with-array-data ((bits sequence :offset-var offset)
+ (start start)
+ (end end)
+ :check-fill-pointer t)
+ (let ((p ,(if (constant-lvar-p item)
+ (case (lvar-value item)
+ (0 `(%bit-position/0 bits from-end start end))
+ (1 `(%bit-position/1 bits from-end start end))
+ (otherwise (throw 'not-a-bit `(values nil nil))))
+ `(%bit-position item bits from-end start end))))
+ (if p
+ (values item (the index (- (truly-the index p) offset)))
+ (values nil nil))))))
+
+(deftransform %find-position ((item sequence from-end start end key test)
(character string t t t function function)
*
:policy (> speed space))
(define-trimmer-transform string-left-trim t nil)
(define-trimmer-transform string-right-trim nil t)
(define-trimmer-transform string-trim t t))
-