X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=0b52e48c455bd6ef9fae87518990b7aba16f9063;hb=bcd323c39d6f5f80020ba4a5d9eb8d348c6cc499;hp=d086e3edfcaa9379e83f163486656431c8613060;hpb=65a29e8b22383bda1d4ac20796c9b56529c02a6e;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index d086e3e..0b52e48 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -643,16 +643,28 @@ (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 @@ -995,7 +1007,8 @@ (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))) @@ -1010,8 +1023,6 @@ 'start) 'result 0 'size element-type) result)))) - ((csubtypep type (specifier-type 'string)) - '(string-subseq* seq start end)) (t '(vector-subseq* seq start end))))) @@ -1032,8 +1043,6 @@ (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))))) @@ -1055,60 +1064,80 @@ :node node :policy (> speed (max space safety))) "open code" - (let ((from-end (when (lvar-p from-end) - (unless (constant-lvar-p from-end) - (give-up-ir1-transform ":FROM-END is not constant.")) - (lvar-value from-end))) - (keyp (lvar-p key)) - (testp (lvar-p test)) - (check-bounds-p (policy node (plusp insert-array-bounds-checks)))) - `(block search - (flet ((oops (vector start end) - (sequence-bounding-indices-bad-error vector start end))) - (let* ((len1 (length pattern)) - (len2 (length text)) - (end1 (or end1 len1)) - (end2 (or end2 len2)) - ,@(when keyp - '((key (coerce key 'function)))) - ,@(when testp - '((test (coerce test 'function))))) - (declare (type index start1 start2 end1 end2)) - ,@(when check-bounds-p - `((unless (<= start1 end1 len1) - (oops pattern start1 end1)) - (unless (<= start2 end2 len2) - (oops pattern start2 end2)))) - (do (,(if from-end - '(index2 (- end2 (- end1 start1)) (1- index2)) - '(index2 start2 (1+ index2)))) - (,(if from-end - '(< index2 start2) - '(>= index2 end2)) - nil) - ;; INDEX2 is FIXNUM, not an INDEX, as right before the loop - ;; terminates is hits -1 when :FROM-END is true and :START2 - ;; is 0. - (declare (type fixnum index2)) - (when (do ((index1 start1 (1+ index1)) - (index2 index2 (1+ index2))) - ((>= index1 end1) t) - (declare (type index index1 index2) - (optimize (insert-array-bounds-checks 0))) - ,@(unless from-end - '((when (= index2 end2) - (return-from search nil)))) - (unless (,@(if testp - '(funcall test) - '(eql)) - ,(if keyp - '(funcall key (aref pattern index1)) - '(aref pattern index1)) - ,(if keyp - '(funcall key (aref text index2)) - '(aref text index2))) - (return nil))) - (return index2)))))))) + (flet ((maybe (x) + (when (lvar-p x) + (if (constant-lvar-p x) + (when (lvar-value x) + :yes) + :maybe)))) + (let ((from-end (when (lvar-p from-end) + (unless (constant-lvar-p from-end) + (give-up-ir1-transform ":FROM-END is not constant.")) + (lvar-value from-end))) + (key? (maybe key)) + (test? (maybe test)) + (check-bounds-p (policy node (plusp insert-array-bounds-checks)))) + `(block search + (flet ((oops (vector start end) + (sequence-bounding-indices-bad-error vector start end))) + (let* ((len1 (length pattern)) + (len2 (length text)) + (end1 (or end1 len1)) + (end2 (or end2 len2)) + ,@(case key? + (:yes `((key (%coerce-callable-to-fun key)))) + (:maybe `((key (when key + (%coerce-callable-to-fun key)))))) + ,@(when test? + `((test (%coerce-callable-to-fun test))))) + (declare (type index start1 start2 end1 end2)) + ,@(when check-bounds-p + `((unless (<= start1 end1 len1) + (oops pattern start1 end1)) + (unless (<= start2 end2 len2) + (oops pattern start2 end2)))) + (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)))) + (,(if from-end + '(< index2 start2) + '(>= index2 end2)) + nil) + ;; INDEX2 is FIXNUM, not an INDEX, as right before the loop + ;; terminates is hits -1 when :FROM-END is true and :START2 + ;; is 0. + (declare (type fixnum index2)) + (when (do ((index1 start1 (1+ index1)) + (index2 index2 (1+ index2))) + ((>= index1 end1) t) + (declare (type index index1 index2) + (optimize (insert-array-bounds-checks 0))) + ,@(unless from-end + '((when (= index2 end2) + (return-from search nil)))) + (unless (,@(if test? + `(funcall test) + `(eql)) + ,(case key? + (:yes `(funcall key (aref pattern index1))) + (:maybe `(let ((elt (aref pattern index1))) + (if key + (funcall key elt) + elt))) + (otherwise `(aref pattern index1))) + ,(case key? + (:yes `(funcall key (aref text index2))) + (:maybe `(let ((elt (aref text index2))) + (if key + (funcall key elt) + elt))) + (otherwise `(aref text index2)))) + (return nil))) + (return index2))))))))) ;;; Open-code CONCATENATE for strings. It would be possible to extend @@ -1415,6 +1444,31 @@ 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))