(if (null splice)
(setq list (cdr x))
(rplacd splice (cdr x))))
- (T (setq splice x)))))
+ (t (setq splice x)))))
(deftransform fill ((seq item &key (start 0) (end (length seq)))
(vector t &key (:start t) (:end index))
;;; must be SIMPLE-BASE-STRINGs.
(macrolet ((def (name lessp equalp)
`(deftransform ,name ((string1 string2 start1 end1 start2 end2)
- (simple-base-string simple-base-string t t t t) *)
+ (simple-base-string simple-base-string t t t t) *)
`(let* ((end1 (if (not end1) (length string1) end1))
(end2 (if (not end2) (length string2) end2))
(index (sb!impl::%sp-string-compare
string1 start1 end1 string2 start2 end2)))
(if index
- (cond ((= index ,(if ',lessp 'end1 'end2)) index)
- ((= index ,(if ',lessp 'end2 'end1)) nil)
+ (cond ((= index end1)
+ ,(if ',lessp 'index nil))
+ ((= (+ index (- start2 start1)) end2)
+ ,(if ',lessp nil 'index))
((,(if ',lessp 'char< 'char>)
(schar string1 index)
(schar string2
(+ index
(truly-the fixnum
(- start2
- start1))))))
+ start1))))))
index)
- (t nil))
+ (t nil))
,(if ',equalp 'end1 nil))))))
(def string<* t nil)
(def string<=* t t)
;;;; type dispatch in AREF. The exception is CONCATENATE, since
;;;; a full call to CONCATENATE would have to look up the sequence
;;;; type, which can be really slow.
-;;;;
-;;;; FIXME: It would be nicer for these transforms to work for any
-;;;; calls when all arguments are vectors with the same element type,
-;;;; rather than restricting them to STRINGs only.
;;; Moved here from generic/vm-tran.lisp to satisfy clisp
;;;
(def!constant vector-data-bit-offset
(* sb!vm:vector-data-offset sb!vm:n-word-bits))
-(deftransform replace ((string1 string2 &key (start1 0) (start2 0)
- end1 end2)
- (simple-base-string simple-base-string &rest t)
- *
- ;; FIXME: consider replacing this policy test
- ;; with some tests for the STARTx and ENDx
- ;; indices being valid, conditional on high
- ;; SAFETY code.
- ;;
- ;; FIXME: It turns out that this transform is
- ;; critical for the performance of string
- ;; streams. Make this more explicit.
- :policy (< (max safety space) 3))
- `(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)))
+ ;; 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~A-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~A-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~A-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)
-;;;
-;;; also, it should be noted that there's nothing much in this
-;;; transform (as opposed to the ones for REPLACE and CONCATENATE)
-;;; that particularly limits it to SIMPLE-BASE-STRINGs.
(deftransform search ((pattern text &key (start1 0) (start2 0) end1 end2)
- (simple-base-string simple-base-string &rest t)
+ (simple-string simple-string &rest t)
*
:policy (> speed (max space safety)))
`(block search
;;; at least once DYNAMIC-EXTENT works.
;;;
;;; FIXME: currently KLUDGEed because of bug 188
+;;;
+;;; FIXME: disabled for sb-unicode: probably want it back
+#!-sb-unicode
(deftransform concatenate ((rtype &rest sequences)
(t &rest (or simple-base-string
(simple-array nil (*))))
(loop for rest-seqs on sequences
for n-seq = (gensym "N-SEQ")
for n-length = (gensym "N-LENGTH")
- for start = vector-data-bit-offset then next-start
+ for start = 0 then next-start
for next-start = (gensym "NEXT-START")
collect n-seq into args
- collect `(,n-length (* (length ,n-seq) sb!vm:n-byte-bits)) into lets
+ collect `(,n-length (length ,n-seq)) into lets
collect n-length into all-lengths
collect next-start into starts
collect `(if (and (typep ,n-seq '(simple-array nil (*)))
(> ,n-length 0))
(error 'nil-array-accessed-error)
- (bit-bash-copy ,n-seq ,vector-data-bit-offset
- res ,start ,n-length))
+ (#.(let* ((i (position 'character sb!kernel::*specialized-array-element-types*))
+ (saetp (aref sb!vm:*specialized-array-element-type-properties* i))
+ (n-bits (sb!vm:saetp-n-bits saetp)))
+ (intern (format nil "UB~D-BASH-COPY" n-bits)
+ "SB!KERNEL"))
+ ,n-seq 0 res ,start ,n-length))
into forms
collect `(setq ,next-start (+ ,start ,n-length)) into forms
finally
`(lambda (rtype ,@args)
(declare (ignore rtype))
(let* (,@lets
- (res (make-string (truncate (the index (+ ,@all-lengths))
- sb!vm:n-byte-bits))))
+ (res (make-string (the index (+ ,@all-lengths))
+ :element-type 'base-char)))
(declare (type index ,@all-lengths))
(let (,@(mapcar (lambda (name) `(,name 0)) starts))
(declare (type index ,@starts))
`(deftransform ,name ((predicate sequence from-end start end key)
(function list t t t function)
*
- :policy (> speed space)
- :important t)
+ :policy (> speed space))
"expand inline"
`(let ((index 0)
(find nil)
(deftransform %find-position ((item sequence from-end start end key test)
(t list t t t t t)
*
- :policy (> speed space)
- :important t)
+ :policy (> speed space))
"expand inline"
'(%find-position-if (let ((test-fun (%coerce-callable-to-fun test)))
;; The order of arguments for asymmetric tests
(deftransform %find-position-if ((predicate sequence from-end start end key)
(function vector t t t function)
*
- :policy (> speed space)
- :important t)
+ :policy (> speed space))
"expand inline"
(check-inlineability-of-find-position-if sequence from-end)
'(%find-position-if-vector-macro predicate sequence
(deftransform %find-position-if-not ((predicate sequence from-end start end key)
(function vector t t t function)
*
- :policy (> speed space)
- :important t)
+ :policy (> speed space))
"expand inline"
(check-inlineability-of-find-position-if sequence from-end)
'(%find-position-if-not-vector-macro predicate sequence
(deftransform %find-position ((item sequence from-end start end key test)
(t vector t t t function function)
*
- :policy (> speed space)
- :important t)
+ :policy (> speed space))
"expand inline"
(check-inlineability-of-find-position-if sequence from-end)
'(%find-position-vector-macro item sequence
;;; perhaps it's worth optimizing the -if-not versions in the same
;;; way as the others?
;;;
-;;; FIXME: Maybe remove uses of these deprecated functions (and
-;;; definitely of :TEST-NOT) within the implementation of SBCL.
+;;; 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)