X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=5694a745b850891dd994e5363628d701d8644a7e;hb=338732358d49ab202fe55c3581294597d63aec6b;hp=b531b36516d67e852f03b75037007f5cf4f6d417;hpb=6053e7f804b430144bb09e2d107ad4ab3fb97db4;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index b531b36..5694a74 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -624,14 +624,16 @@ ;;; 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 @@ -639,9 +641,9 @@ (+ index (truly-the fixnum (- start2 - start1)))))) + start1)))))) index) - (t nil)) + (t nil)) ,(if ',equalp 'end1 nil)))))) (def string<* t nil) (def string<=* t t) @@ -669,10 +671,6 @@ ;;;; 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 ;;; @@ -681,36 +679,121 @@ (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) +(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)))))) ;;; FIXME: It seems as though it should be possible to make a DEFUN ;;; %CONCATENATE (with a DEFTRANSFORM to translate constant RTYPE to @@ -718,6 +801,9 @@ ;;; 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 (*)))) @@ -745,7 +831,8 @@ (declare (ignore rtype)) (let* (,@lets (res (make-string (truncate (the index (+ ,@all-lengths)) - sb!vm:n-byte-bits)))) + sb!vm:n-byte-bits) + :element-type 'base-char))) (declare (type index ,@all-lengths)) (let (,@(mapcar (lambda (name) `(,name 0)) starts)) (declare (type index ,@starts)) @@ -796,8 +883,7 @@ `(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) @@ -843,8 +929,7 @@ (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 @@ -937,8 +1022,7 @@ (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 @@ -947,8 +1031,7 @@ (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 @@ -957,8 +1040,7 @@ (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 @@ -1030,8 +1112,8 @@ ;;; 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)