From 44623fcbef08695403f96ac740807f5abe376307 Mon Sep 17 00:00:00 2001 From: Gabor Melis Date: Sun, 10 Aug 2008 21:18:32 +0000 Subject: [PATCH] 1.0.19.27: more ir1 transforms for REPLACE Supplying START1 or START2 does not inhibit ir1 transforms for specialized array types. --- NEWS | 2 ++ src/compiler/seqtran.lisp | 85 +++++++++++++++++------------------------------ version.lisp-expr | 2 +- 3 files changed, 34 insertions(+), 55 deletions(-) diff --git a/NEWS b/NEWS index df60f6406..0cfec0242 100644 --- a/NEWS +++ b/NEWS @@ -21,6 +21,8 @@ changes in sbcl-1.0.20 relative to 1.0.19: (AREF (THE STRING X) Y) as being CHARACTER. * optimization: CLRHASH on empty hash-tables no longer does pointless work. (thanks to Alec Berryman) + * optimization: REPLACE deftransforms don't punt when :START1 or + :START2 is given * bug fix: bogus odd-number-of-keywords STYLE-WARNINGs from calls to functions with an odd number of &OPTIONAL arguments, a &REST argument, and one or more &KEY arguments at the call site. diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 7d5a93574..6b4cef73b 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -547,22 +547,6 @@ :start start :end (%check-generic-sequence-bounds seq start end))) -;;;; utilities - -;;; If LVAR is a constant lvar, the return the constant value. If it -;;; is null, then return default, otherwise quietly give up the IR1 -;;; transform. -;;; -;;; ### Probably should take an ARG and flame using the NAME. -(defun constant-value-or-lose (lvar &optional default) - (declare (type (or lvar null) lvar)) - (cond ((not lvar) default) - ((constant-lvar-p lvar) - (lvar-value lvar)) - (t - (give-up-ir1-transform)))) - - ;;;; hairy sequence transforms ;;; FIXME: no hairy sequence transforms in SBCL? @@ -698,51 +682,44 @@ (,sequence-type1 ,sequence-type2 &rest t) ,sequence-type1 :node node) - ,(cond - ((and saetp (valid-bit-bash-saetp-p saetp)) nil) - ;; If the sequence types are different, SEQ1 and SEQ2 must - ;; be distinct arrays, and we can open code the copy loop. - ((not (eql sequence-type1 sequence-type2)) nil) - ;; If we're not bit-bashing, only allow cases where we - ;; can determine the order of copying up front. (There - ;; are actually more cases we can handle if we know the - ;; amount that we're copying, but this handles the - ;; common cases.) - (t '(unless (= (constant-value-or-lose start1 0) - (constant-value-or-lose start2 0)) - (give-up-ir1-transform)))) `(let* ((len1 (length seq1)) (len2 (length seq2)) (end1 (or end1 len1)) (end2 (or end2 len2)) - (replace-len1 (- end1 start1)) - (replace-len2 (- end2 start2))) + (replace-len (min (- end1 start1) (- end2 start2)))) ,(unless (policy node (= safety 0)) `(progn - (unless (<= 0 start1 end1 len1) - (sequence-bounding-indices-bad-error seq1 start1 end1)) - (unless (<= 0 start2 end2 len2) - (sequence-bounding-indices-bad-error seq2 start2 end2)))) + (unless (<= 0 start1 end1 len1) + (sequence-bounding-indices-bad-error seq1 start1 end1)) + (unless (<= 0 start2 end2 len2) + (sequence-bounding-indices-bad-error seq2 start2 end2)))) ,',(cond - ((and saetp (valid-bit-bash-saetp-p saetp)) - (let* ((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")))) - `(funcall (function ,bash-function) seq2 start2 - seq1 start1 (min replace-len1 replace-len2)))) - (t - ;; We can expand the loop inline here because we - ;; would have given up the transform (see above) - ;; if we didn't have constant matching start - ;; indices. - '(do ((i start1 (1+ i)) - (j start2 (1+ j)) - (end (+ start1 - (min replace-len1 replace-len2)))) - ((>= i end)) - (declare (optimize (insert-array-bounds-checks 0))) - (setf (aref seq1 i) (aref seq2 j))))) + ((and saetp (valid-bit-bash-saetp-p saetp)) + (let* ((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")))) + `(funcall (function ,bash-function) seq2 start2 + seq1 start1 replace-len))) + (t + `(if (and + ;; If the sequence types are different, SEQ1 and + ;; SEQ2 must be distinct arrays. + ,(eql sequence-type1 sequence-type2) + (eq seq1 seq2) (> start1 start2)) + (do ((i (truly-the index (+ start1 replace-len -1)) + (1- i)) + (j (truly-the index (+ start2 replace-len -1)) + (1- j))) + ((< i start1)) + (declare (optimize (insert-array-bounds-checks 0))) + (setf (aref seq1 i) (aref seq2 j))) + (do ((i start1 (1+ i)) + (j start2 (1+ j)) + (end (+ start1 replace-len))) + ((>= i end)) + (declare (optimize (insert-array-bounds-checks 0))) + (setf (aref seq1 i) (aref seq2 j)))))) seq1)))) (macrolet diff --git a/version.lisp-expr b/version.lisp-expr index 52e70ee73..157799d23 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.19.26" +"1.0.19.27" -- 2.11.4.GIT