X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fseqtran.lisp;h=a7a33b76fdfb63bc1a7706051e640e2a24fedf2a;hb=2253ebaef8a0a1527d2282a1c10f48c62e0d4a83;hp=b20f4db127ee576e588499bef7c77afbb4f8ebc4;hpb=5cc68148d1a5f9bacf4eb12e396b680d992fc2c2;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index b20f4db..a7a33b7 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -349,7 +349,7 @@ (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)) @@ -671,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 ;;; @@ -683,59 +679,103 @@ (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)) - -;;; KLUDGE: This isn't the nicest way of achieving efficient string -;;; streams, but it does work; a more general framework for this kind -;;; of optimization, as well as better handling of the possible -;;; keyword arguments, would be nice. -#!+sb-unicode -(deftransform replace ((string1 string2 &key (start1 0) (start2 0) - end1 end2) - ((simple-array character (*)) - (simple-array character (*)) - &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)) - `(sb!impl::simple-character-string-replace-from-simple-character-string* - string1 string2 start1 end1 start2 end2)) +(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= @@ -776,17 +816,21 @@ (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 @@ -794,9 +838,8 @@ `(lambda (rtype ,@args) (declare (ignore rtype)) (let* (,@lets - (res (make-string (truncate (the index (+ ,@all-lengths)) - sb!vm:n-byte-bits) - :element-type 'base-char))) + (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))