From c49d74c70beef5fb0c8774a571b7c074aba9b851 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 30 Nov 2007 13:12:21 +0000 Subject: [PATCH] 1.0.12.7: oops, missed one SEARCH transform * Check bounds properly before entry to the code, and elide checks in the inner loop. --- src/compiler/seqtran.lisp | 92 ++++++++++++++++++++++++------------------- tests/pathnames.impure.lisp | 2 +- version.lisp-expr | 2 +- 3 files changed, 54 insertions(+), 42 deletions(-) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index a7d55cd..eafa639 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -287,9 +287,9 @@ (if (policy node (= 0 insert-array-bounds-checks)) '(or end (length vector)) '(let ((length (length vector))) - (if (<= 0 start (or end length) length) - (or end length) - (sb!impl::signal-bounding-indices-bad-error vector start end))))) + (if (<= 0 start (or end length) length) + (or end length) + (sb!impl::signal-bounding-indices-bad-error vector start end))))) (defun specialized-list-seek-function-name (function-name key-functions) (or (find-symbol (with-output-to-string (s) @@ -825,6 +825,7 @@ from-end) (vector vector &rest t) * + :node node :policy (> speed (max space safety))) "open code" (let ((from-end (when (lvar-p from-end) @@ -832,44 +833,55 @@ (give-up-ir1-transform ":FROM-END is not constant.")) (lvar-value from-end))) (keyp (lvar-p key)) - (testp (lvar-p test))) + (testp (lvar-p test)) + (check-bounds-p (policy node (plusp insert-array-bounds-checks)))) `(block search - (let ((end1 (or end1 (length pattern))) - (end2 (or end2 (length text))) - ,@(when keyp - '((key (coerce key 'function)))) - ,@(when testp - '((test (coerce test 'function))))) - (declare (type index start1 start2 end1 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)) - ,@(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 ((oops (vector start end) + (bounding-index-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)))))))) ;;; Open-code CONCATENATE for strings. It would be possible to extend diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index bd90a42..a46c6e0 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -452,7 +452,7 @@ #+win32 #|type NIL :UNSPECIFIC "" "a" |# -#|name |# +#|name |# #|NIL |# '("C:\\tmp\\" "C:\\tmp\\" NIL NIL #|:UNSPECIFIC|# "C:\\tmp\\" "C:\\tmp\\" NIL NIL #|"" |# "C:\\tmp\\" "C:\\tmp\\" "C:\\tmp\\." "C:\\tmp\\.a" diff --git a/version.lisp-expr b/version.lisp-expr index 783e6f8..cbfce67 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.12.6" +"1.0.12.7" -- 1.7.10.4