-;;; FIXME: Shouldn't we be testing for legality of
-;;; * START1, START2, END1, and END2 indices?
-;;; * size of copied string relative to destination string?
-;;; (Either there should be tests conditional on SAFETY>=SPEED, or
-;;; the transform should be conditional on SPEED>SAFETY.)
-;;;
-;;; FIXME: Also, the transform should probably be dependent on
-;;; SPEED>SPACE.
-(deftransform replace ((string1 string2 &key (start1 0) (start2 0)
- end1 end2)
- (simple-string simple-string &rest t))
- `(locally
- (declare (optimize (safety 0)))
- (bit-bash-copy string2
- (the index
- (+ (the index (* start2 sb!vm:n-byte-bits))
- ,vector-data-bit-offset))
- string1
- (the index
- (+ (the index (* start1 sb!vm:n-byte-bits))
- ,vector-data-bit-offset))
- (the index
- (* (min (the index (- (or end1 (length string1))
- start1))
- (the index (- (or end2 (length string2))
- start2)))
- sb!vm:n-byte-bits)))
- string1))
+(eval-when (:compile-toplevel)
+(defun valid-bit-bash-saetp-p (saetp)
+ ;; BIT-BASHing isn't allowed on simple vectors that contain pointers
+ (and (not (eq t (sb!vm:saetp-specifier saetp)))
+ ;; Disallowing (VECTOR NIL) also means that we won't transform
+ ;; sequence functions into bit-bashing code and we let the
+ ;; generic sequence functions signal errors if necessary.
+ (not (zerop (sb!vm:saetp-n-bits saetp)))
+ ;; Due to limitations with the current BIT-BASHing code, we can't
+ ;; BIT-BASH reliably on arrays whose element types are larger
+ ;; than the word size.
+ (<= (sb!vm:saetp-n-bits saetp) sb!vm:n-word-bits)))
+) ; EVAL-WHEN
+
+;; FIXME: It turns out that this transform (for SIMPLE-BASE-STRINGS)
+;; is critical for the performance of string streams. Make this
+;; more explicit.
+(macrolet
+ ((define-replace-transforms ()
+ (loop for saetp across sb!vm:*specialized-array-element-type-properties*
+ when (valid-bit-bash-saetp-p saetp)
+ collect
+ (let* ((sequence-type `(simple-array ,(sb!vm:saetp-specifier saetp) (*)))
+ (n-element-bits (sb!vm:saetp-n-bits saetp))
+ (bash-function (intern (format nil "UB~D-BASH-COPY" n-element-bits)
+ (find-package "SB!KERNEL"))))
+ `(deftransform replace ((seq1 seq2 &key (start1 0) (start2 0) end1 end2)
+ (,sequence-type ,sequence-type &rest t)
+ ,sequence-type
+ :node node)
+ `(let* ((len1 (length seq1))
+ (len2 (length seq2))
+ (end1 (or end1 len1))
+ (end2 (or end2 len2))
+ (replace-len1 (- end1 start1))
+ (replace-len2 (- end2 start2)))
+ ,(unless (policy node (= safety 0))
+ `(progn
+ (unless (<= 0 start1 end1 len1)
+ (sb!impl::signal-bounding-indices-bad-error seq1 start1 end1))
+ (unless (<= 0 start2 end2 len2)
+ (sb!impl::signal-bounding-indices-bad-error seq2 start2 end2))))
+ (funcall (function ,',bash-function)
+ seq2 start2
+ seq1 start1
+ (min replace-len1 replace-len2))
+ seq1)))
+ into forms
+ finally (return `(progn ,@forms)))))
+ (define-replace-transforms))
+
+(macrolet
+ ((define-subseq-transforms ()
+ (loop for saetp across sb!vm:*specialized-array-element-type-properties*
+ when (valid-bit-bash-saetp-p saetp)
+ collect
+ (let* ((sequence-type `(simple-array ,(sb!vm:saetp-specifier saetp) (*)))
+ (n-element-bits (sb!vm:saetp-n-bits saetp))
+ (bash-function (intern (format nil "UB~D-BASH-COPY" n-element-bits)
+ (find-package "SB!KERNEL"))))
+ `(deftransform subseq ((seq start &optional end)
+ (,sequence-type t &optional t)
+ ,sequence-type :node node)
+ `(let* ((length (length seq))
+ (end (if end (min end length) length)))
+ ,(unless (policy node (= safety 0))
+ `(progn
+ (unless (<= 0 start end length)
+ (sb!impl::signal-bounding-indices-bad-error seq start end))))
+ (let* ((size (- end start))
+ (result (make-array size :element-type ',',(sb!vm:saetp-specifier saetp))))
+ (funcall (function ,',bash-function)
+ seq start result 0 size)
+ result))))
+ into forms
+ finally (return `(progn ,@forms)))))
+ (define-subseq-transforms))
+
+(macrolet
+ ((define-copy-seq-transforms ()
+ (loop for saetp across sb!vm:*specialized-array-element-type-properties*
+ when (valid-bit-bash-saetp-p saetp)
+ collect
+ (let* ((sequence-type `(simple-array ,(sb!vm:saetp-specifier saetp) (*)))
+ (n-element-bits (sb!vm:saetp-n-bits saetp))
+ (bash-function (intern (format nil "UB~D-BASH-COPY" n-element-bits)
+ (find-package "SB!KERNEL"))))
+ `(deftransform copy-seq ((seq) (,sequence-type)
+ ,sequence-type)
+ `(let* ((length (length seq))
+ (result (make-array length :element-type ',',(sb!vm:saetp-specifier saetp))))
+ (funcall (function ,',bash-function)
+ seq 0 result 0 length)
+ result)))
+ into forms
+ finally (return `(progn ,@forms)))))
+ (define-copy-seq-transforms))
+
+;;; FIXME: this would be a valid transform for certain excluded cases:
+;;; * :TEST 'CHAR= or :TEST #'CHAR=
+;;; * :TEST 'EQL or :TEST #'EQL
+;;; * :FROM-END NIL (or :FROM-END non-NIL, with a little ingenuity)
+(deftransform search ((pattern text &key (start1 0) (start2 0) end1 end2)
+ (simple-string simple-string &rest t)
+ *
+ :policy (> speed (max space safety)))
+ `(block search
+ (let ((end1 (or end1 (length pattern)))
+ (end2 (or end2 (length text))))
+ (do ((index2 start2 (1+ index2)))
+ ((>= index2 end2) nil)
+ (when (do ((index1 start1 (1+ index1))
+ (index2 index2 (1+ index2)))
+ ((>= index1 end1) t)
+ (when (= index2 end2)
+ (return-from search nil))
+ (when (char/= (char pattern index1) (char text index2))
+ (return nil)))
+ (return index2))))))