From 26265f96389d737bf2e1e4c787ea8943ae499944 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 29 Nov 2007 17:30:11 +0000 Subject: [PATCH] 1.0.12.5: WITH-ARRAY-DATA touchups * Eliminate some double-bounds checks: since WITH-ARRAY-DATA does bounds checking, there is no need to vet START and END with %CHECK-VECTOR-SEQUENCE-BOUNDS. * Eliminate some fill-pointer confusion: Since WITH-ARRAY-DATA is used both in contexts where fill-pointer needs to be used, and in contexts where we only care about the total array size, add a :CHECK-FILL-POINTER argument to WITH-ARRAY-DATA. * Do bounds checking in WITH-ARRAY-DATA based on INSERT-ARRAY-BOUNDS-CHECKS policy -- not SPEED vs. SAFETY comparison. Adjust tests to check for this. --- NEWS | 2 + contrib/sb-md5/md5.lisp | 5 +- package-data-list.lisp-expr | 6 +- src/code/array.lisp | 13 ++-- src/code/cross-misc.lisp | 4 ++ src/code/octets.lisp | 6 +- src/code/print.lisp | 3 +- src/code/reader.lisp | 6 +- src/code/seq.lisp | 4 +- src/code/sort.lisp | 5 +- src/code/stream.lisp | 21 +++--- src/code/string.lisp | 15 ++-- src/code/timer.lisp | 2 +- src/compiler/array-tran.lisp | 160 ++++++++++++++++++++++++++----------------- src/compiler/fndb.lisp | 6 +- src/compiler/seqtran.lisp | 33 +++++---- tests/seq.impure.lisp | 11 +-- version.lisp-expr | 2 +- 18 files changed, 178 insertions(+), 126 deletions(-) diff --git a/NEWS b/NEWS index 739621bb5..6b6f3cc91 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,7 @@ ;;;; -*- coding: utf-8; -*- changes in sbcl-1.0.13 relative to sbcl-1.0.12: + * bug fix: some sequence functions elided bounds checking when + SPEED > SAFETY. * bug fix: too liberal weakening of union-type checks when SPEED > SAFETY. * bug fix: more bogus fixnum declarations in ROOM implementation diff --git a/contrib/sb-md5/md5.lisp b/contrib/sb-md5/md5.lisp index 54d5810ca..5667e59d7 100644 --- a/contrib/sb-md5/md5.lisp +++ b/contrib/sb-md5/md5.lisp @@ -525,7 +525,10 @@ in SEQUENCE , which must be a vector with element-type (UNSIGNED-BYTE #+sbcl ;; respect the fill pointer (let ((end (or end (length sequence)))) - (sb-kernel:with-array-data ((data sequence) (real-start start) (real-end end)) + (sb-kernel:with-array-data ((data sequence) + (real-start start) + (real-end end) + :check-fill-pointer t) (declare (ignore real-end)) (update-md5-state state data :start real-start :end (+ real-start (- end start))))) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index abad96173..6b7eab49a 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1209,7 +1209,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%SINH" "%SQRT" "%SXHASH-SIMPLE-STRING" "%SXHASH-SIMPLE-SUBSTRING" "%TAN" "%TAN-QUICK" "%TANH" "%UNARY-ROUND" "%UNARY-TRUNCATE" "%UNARY-FTRUNCATE" - "%WITH-ARRAY-DATA" "%WITH-ARRAY-DATA-MACRO" + "%WITH-ARRAY-DATA" + "%WITH-ARRAY-DATA/FP" + "%WITH-ARRAY-DATA-MACRO" "*CURRENT-LEVEL-IN-PRINT*" "*EMPTY-TYPE*" "*GC-INHIBIT*" "*GC-PENDING*" #!+sb-thread "*STOP-FOR-GC-PENDING*" @@ -1280,7 +1282,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "EFFECTIVE-FIND-POSITION-TEST" "EFFECTIVE-FIND-POSITION-KEY" "ERROR-NUMBER-OR-LOSE" "EXTENDED-CHAR-P" - "FAILED-%WITH-ARRAY-DATA" "FDEFINITION-OBJECT" + "FDEFINITION-OBJECT" "FDOCUMENTATION" "FILENAME" "FIND-AND-INIT-OR-CHECK-LAYOUT" "FIND-DEFSTRUCT-DESCRIPTION" diff --git a/src/code/array.lisp b/src/code/array.lisp index 817bdb783..3a9d70305 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -46,8 +46,11 @@ (fixnum index)) (%check-bound array bound index)) +(defun %with-array-data/fp (array start end) + (%with-array-data-macro array start end :check-bounds t :check-fill-pointer t)) + (defun %with-array-data (array start end) - (%with-array-data-macro array start end :fail-inline? t)) + (%with-array-data-macro array start end :check-bounds t :check-fill-pointer nil)) (defun %data-vector-and-index (array index) (if (array-header-p array) @@ -55,14 +58,6 @@ (%with-array-data array index nil) (values vector index)) (values array index))) - -;;; It'd waste space to expand copies of error handling in every -;;; inline %WITH-ARRAY-DATA, so we have them call this function -;;; instead. This is just a wrapper which is known never to return. -(defun failed-%with-array-data (array start end) - (declare (notinline %with-array-data)) - (%with-array-data array start end) - (bug "called FAILED-%WITH-ARRAY-DATA with valid array parameters?")) ;;;; MAKE-ARRAY (eval-when (:compile-toplevel :execute) diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index 0bc086e74..530782a4e 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -150,6 +150,10 @@ (assert (typep array '(simple-array * (*)))) (values array start end 0)) +(defun sb!kernel:%with-array-data/fp (array start end) + (assert (typep array '(simple-array * (*)))) + (values array start end 0)) + (defun sb!kernel:signed-byte-32-p (number) (typep number '(signed-byte 32))) diff --git a/src/code/octets.lisp b/src/code/octets.lisp index 014f2e2d9..eb87cd1a8 100644 --- a/src/code/octets.lisp +++ b/src/code/octets.lisp @@ -817,7 +817,8 @@ one-past-the-end" (declare (type (vector (unsigned-byte 8)) vector)) (with-array-data ((vector vector) (start start) - (end (%check-vector-sequence-bounds vector start end))) + (end end) + :check-fill-pointer t) (declare (type (simple-array (unsigned-byte 8) (*)) vector)) (funcall (symbol-function (first (external-formats-funs external-format))) vector start end))) @@ -827,7 +828,8 @@ one-past-the-end" (declare (type string string)) (with-array-data ((string string) (start start) - (end (%check-vector-sequence-bounds string start end))) + (end end) + :check-fill-pointer t) (declare (type simple-string string)) (funcall (symbol-function (second (external-formats-funs external-format))) string start end (if null-terminate 1 0)))) diff --git a/src/code/print.lisp b/src/code/print.lisp index e9b58d0a8..e235f4b2b 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -908,7 +908,8 @@ ;; this for now. [noted by anonymous long ago] -- WHN 19991130 `(or (char= ,char #\\) (char= ,char #\")))) - (with-array-data ((data string) (start) (end (length string))) + (with-array-data ((data string) (start) (end) + :check-fill-pointer t) (do ((index start (1+ index))) ((>= index end)) (let ((char (schar data index))) diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 3bcf87814..94d5ca74c 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -1521,7 +1521,8 @@ variables to allow for nested and thread safe reading." (declare (string string)) (with-array-data ((string string :offset-var offset) (start start) - (end (%check-vector-sequence-bounds string start end))) + (end end) + :check-fill-pointer t) (let ((stream (make-string-input-stream string start end))) (values (if preserve-whitespace (read-preserving-whitespace stream eof-error-p eof-value) @@ -1542,7 +1543,8 @@ variables to allow for nested and thread safe reading." :format-arguments (list string)))) (with-array-data ((string string :offset-var offset) (start start) - (end (%check-vector-sequence-bounds string start end))) + (end end) + :check-fill-pointer t) (let ((index (do ((i start (1+ i))) ((= i end) (if junk-allowed diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 859fed3e8..c5c6bd84a 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -2132,8 +2132,8 @@ (frob sequence-arg from-end) (with-array-data ((sequence sequence-arg :offset-var offset) (start start) - (end (%check-vector-sequence-bounds - sequence-arg start end))) + (end end) + :check-fill-pointer t) (multiple-value-bind (f p) (macrolet ((frob2 () '(if from-end (frob sequence t) diff --git a/src/code/sort.lisp b/src/code/sort.lisp index e285dabe1..83e98984a 100644 --- a/src/code/sort.lisp +++ b/src/code/sort.lisp @@ -31,8 +31,9 @@ (if key (%coerce-callable-to-fun key) #'identity)) (let ((key-fun-or-nil (and key (%coerce-callable-to-fun key)))) (with-array-data ((vector (the vector sequence)) - (start 0) - (end (length sequence))) + (start) + (end) + :check-fill-pointer t) (sort-vector vector start end predicate-fun key-fun-or-nil)) sequence) (apply #'sb!sequence:sort sequence predicate args)))) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 88b2f9870..799e2428b 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -572,12 +572,11 @@ (declare (type string string)) (declare (type ansi-stream stream)) (declare (type index start end)) - (if (array-header-p string) - (with-array-data ((data string) (offset-start start) - (offset-end end)) - (funcall (ansi-stream-sout stream) - stream data offset-start offset-end)) - (funcall (ansi-stream-sout stream) stream string start end)) + (with-array-data ((data string) (offset-start start) + (offset-end end) + :check-fill-pointer t) + (funcall (ansi-stream-sout stream) + stream data offset-start offset-end)) string) (defun %write-string (string stream start end) @@ -1181,8 +1180,8 @@ (declare (type string string) (type index start) (type (or index null) end)) - (let* ((string (coerce string '(simple-array character (*)))) - (end (%check-vector-sequence-bounds string start end))) + (let* ((string (coerce string '(simple-array character (*))))) + ;; FIXME: Why WITH-ARRAY-DATA, since the array is already simple? (with-array-data ((string string) (start start) (end end)) (internal-make-string-input-stream string ;; now simple @@ -1969,7 +1968,8 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") (return i)) (setf (first rem) el))))) (vector - (with-array-data ((data seq) (offset-start start) (offset-end end)) + (with-array-data ((data seq) (offset-start start) (offset-end end) + :check-fill-pointer t) (if (compatible-vector-and-stream-element-types-p data stream) (let* ((numbytes (- end start)) (bytes-read (read-n-bytes stream data offset-start @@ -2036,7 +2036,8 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") (string (%write-string seq stream start end)) (vector - (with-array-data ((data seq) (offset-start start) (offset-end end)) + (with-array-data ((data seq) (offset-start start) (offset-end end) + :check-fill-pointer t) (labels ((output-seq-in-loop () (let ((write-function diff --git a/src/code/string.lisp b/src/code/string.lisp index 67579f713..f90b2968f 100644 --- a/src/code/string.lisp +++ b/src/code/string.lisp @@ -47,15 +47,16 @@ `(let* ((,string (if (stringp ,string) ,string (string ,string)))) (with-array-data ((,string ,string) (,start ,start) - (,end - (%check-vector-sequence-bounds ,string ,start ,end))) + (,end ,end) + :check-fill-pointer t) ,@forms))) ;;; WITH-STRING is like WITH-ONE-STRING, but doesn't parse keywords. (sb!xc:defmacro with-string (string &rest forms) `(let ((,string (if (stringp ,string) ,string (string ,string)))) (with-array-data ((,string ,string) (start) - (end (length (the vector ,string)))) + (end) + :check-fill-pointer t) ,@forms))) ;;; WITH-TWO-STRINGS is used to set up string comparison operations. The ;;; keywords are parsed, and the strings are hacked into SIMPLE-STRINGs. @@ -65,12 +66,12 @@ (,string2 (if (stringp ,string2) ,string2 (string ,string2)))) (with-array-data ((,string1 ,string1 :offset-var ,cum-offset-1) (,start1 ,start1) - (,end1 (%check-vector-sequence-bounds - ,string1 ,start1 ,end1))) + (,end1 ,end1) + :check-fill-pointer t) (with-array-data ((,string2 ,string2) (,start2 ,start2) - (,end2 (%check-vector-sequence-bounds - ,string2 ,start2 ,end2))) + (,end2 ,end2) + :check-fill-pointer t) ,@forms)))) ) ; EVAL-WHEN diff --git a/src/code/timer.lisp b/src/code/timer.lisp index 774ee2b4a..b644f712e 100644 --- a/src/code/timer.lisp +++ b/src/code/timer.lisp @@ -65,7 +65,7 @@ (aref heap 0))) (defun heap-extract (heap i &key (key #'identity) (test #'>=)) - (when (< (length heap) i) + (unless (> (length heap) i) (error "Heap underflow")) (prog1 (aref heap i) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 357997579..2026bb249 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -136,13 +136,17 @@ ;;; Figure out the type of the data vector if we know the argument ;;; element type. -(defoptimizer (%with-array-data derive-type) ((array start end)) +(defun derive-%with-array-data/mumble-type (array) (let ((atype (lvar-type array))) (when (array-type-p atype) (specifier-type `(simple-array ,(type-specifier - (array-type-specialized-element-type atype)) - (*)))))) + (array-type-specialized-element-type atype)) + (*)))))) +(defoptimizer (%with-array-data derive-type) ((array start end)) + (derive-%with-array-data/mumble-type array)) +(defoptimizer (%with-array-data/fp derive-type) ((array start end)) + (derive-%with-array-data/mumble-type array)) (defoptimizer (array-row-major-index derive-type) ((array &rest indices)) (assert-array-rank array (length indices)) @@ -560,10 +564,27 @@ (give-up-ir1-transform)) (t (let ((dim (lvar-value dimension))) + ;; FIXME: Can SPEED > SAFETY weaken this check to INTEGER? `(the (integer 0 (,dim)) index))))) ;;;; WITH-ARRAY-DATA +(defun bounding-index-error (array start end) + (let ((size (array-total-size array))) + (error 'bounding-indices-bad-error + :datum (cons start end) + :expected-type `(cons (integer 0 ,size) + (integer ,start ,size)) + :object array))) + +(defun bounding-index-error/fp (array start end) + (let ((size (length array))) + (error 'bounding-indices-bad-error + :datum (cons start end) + :expected-type `(cons (integer 0 ,size) + (integer ,start ,size)) + :object array))) + ;;; This checks to see whether the array is simple and the start and ;;; end are in bounds. If so, it proceeds with those values. ;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that %WITH-ARRAY-DATA @@ -589,29 +610,39 @@ (def!macro with-array-data (((data-var array &key offset-var) (start-var &optional (svalue 0)) (end-var &optional (evalue nil)) - &key force-inline) - &body forms) + &key force-inline check-fill-pointer) + &body forms + &environment env) (once-only ((n-array array) (n-svalue `(the index ,svalue)) (n-evalue `(the (or index null) ,evalue))) - `(multiple-value-bind (,data-var - ,start-var - ,end-var - ,@(when offset-var `(,offset-var))) - (if (not (array-header-p ,n-array)) - (let ((,n-array ,n-array)) - (declare (type (simple-array * (*)) ,n-array)) - ,(once-only ((n-len `(length ,n-array)) - (n-end `(or ,n-evalue ,n-len))) - `(if (<= ,n-svalue ,n-end ,n-len) - ;; success - (values ,n-array ,n-svalue ,n-end 0) - (failed-%with-array-data ,n-array - ,n-svalue - ,n-evalue)))) - (,(if force-inline '%with-array-data-macro '%with-array-data) - ,n-array ,n-svalue ,n-evalue)) - ,@forms))) + (let ((check-bounds (policy env (= 0 insert-array-bounds-checks)))) + `(multiple-value-bind (,data-var + ,start-var + ,end-var + ,@(when offset-var `(,offset-var))) + (if (not (array-header-p ,n-array)) + (let ((,n-array ,n-array)) + (declare (type (simple-array * (*)) ,n-array)) + ,(once-only ((n-len (if check-fill-pointer + `(length ,n-array) + `(array-total-size ,n-array))) + (n-end `(or ,n-evalue ,n-len))) + (if check-bounds + `(values ,n-array ,n-svalue ,n-end 0) + `(if (<= ,n-svalue ,n-end ,n-len) + (values ,n-array ,n-svalue ,n-end 0) + ,(if check-fill-pointer + `(bounding-index-error/fp ,n-array ,n-svalue ,n-evalue) + `(bounding-index-error ,n-array ,n-svalue ,n-evalue)))))) + ,(if force-inline + `(%with-array-data-macro ,n-array ,n-svalue ,n-evalue + :check-bounds ,check-bounds + :check-fill-pointer ,check-fill-pointer) + (if check-fill-pointer + `(%with-array-data/fp ,n-array ,n-svalue ,n-evalue) + `(%with-array-data ,n-array ,n-svalue ,n-evalue)))) + ,@forms)))) ;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in ;;; DEFTRANSFORMs and DEFUNs. @@ -620,30 +651,18 @@ end &key (element-type '*) - unsafe? - fail-inline?) + check-bounds + check-fill-pointer) (with-unique-names (size defaulted-end data cumulative-offset) - `(let* ((,size (array-total-size ,array)) - (,defaulted-end - (cond (,end - (unless (or ,unsafe? (<= ,end ,size)) - ,(if fail-inline? - `(error 'bounding-indices-bad-error - :datum (cons ,start ,end) - :expected-type `(cons (integer 0 ,',size) - (integer ,',start ,',size)) - :object ,array) - `(failed-%with-array-data ,array ,start ,end))) - ,end) - (t ,size)))) - (unless (or ,unsafe? (<= ,start ,defaulted-end)) - ,(if fail-inline? - `(error 'bounding-indices-bad-error - :datum (cons ,start ,end) - :expected-type `(cons (integer 0 ,',size) - (integer ,',start ,',size)) - :object ,array) - `(failed-%with-array-data ,array ,start ,end))) + `(let* ((,size ,(if check-fill-pointer + `(length ,array) + `(array-total-size ,array))) + (,defaulted-end (or ,end ,size))) + ,@(when check-bounds + `((unless (<= ,start ,defaulted-end ,size) + ,(if check-fill-pointer + `(bounding-index-error/fp ,array ,start ,end) + `(bounding-index-error ,array ,start ,end))))) (do ((,data ,array (%array-data-vector ,data)) (,cumulative-offset 0 (+ ,cumulative-offset @@ -655,34 +674,47 @@ (the index ,cumulative-offset))) (declare (type index ,cumulative-offset)))))) -(deftransform %with-array-data ((array start end) - ;; It might very well be reasonable to - ;; allow general ARRAY here, I just - ;; haven't tried to understand the - ;; performance issues involved. -- - ;; WHN, and also CSR 2002-05-26 - ((or vector simple-array) index (or index null)) - * - :node node - :policy (> speed space)) - "inline non-SIMPLE-vector-handling logic" +(defun transform-%with-array-data/muble (array node check-fill-pointer) (let ((element-type (upgraded-element-type-specifier-or-give-up array)) (type (lvar-type array))) (if (and (array-type-p type) (listp (array-type-dimensions type)) (not (null (cdr (array-type-dimensions type))))) - ;; If it's a simple multidimensional array, then just return its - ;; data vector directly rather than going through - ;; %WITH-ARRAY-DATA-MACRO. SBCL doesn't generally generate code - ;; that would use this currently, but we have encouraged users - ;; to use WITH-ARRAY-DATA and we may use it ourselves at some - ;; point in the future for optimized libraries or similar. + ;; If it's a simple multidimensional array, then just return + ;; its data vector directly rather than going through + ;; %WITH-ARRAY-DATA-MACRO. SBCL doesn't generally generate + ;; code that would use this currently, but we have encouraged + ;; users to use WITH-ARRAY-DATA and we may use it ourselves at + ;; some point in the future for optimized libraries or + ;; similar. + ;; + ;; FIXME: The return values here don't seem sane, and + ;; bounds-checks are elided! `(let ((data (truly-the (simple-array ,element-type (*)) (%array-data-vector array)))) (values data 0 (length data) 0)) `(%with-array-data-macro array start end - :unsafe? ,(policy node (= safety 0)) + :check-fill-pointer ,check-fill-pointer + :check-bounds ,(policy node (< 0 insert-array-bounds-checks)) :element-type ,element-type)))) + +;; It might very well be reasonable to allow general ARRAY here, I +;; just haven't tried to understand the performance issues involved. +;; -- WHN, and also CSR 2002-05-26 +(deftransform %with-array-data ((array start end) + ((or vector simple-array) index (or index null) t) + * + :node node + :policy (> speed space)) + "inline non-SIMPLE-vector-handling logic" + (transform-%with-array-data/muble array node nil)) +(deftransform %with-array-data/fp ((array start end) + ((or vector simple-array) index (or index null) t) + * + :node node + :policy (> speed space)) + "inline non-SIMPLE-vector-handling logic" + (transform-%with-array-data/muble array node t)) ;;;; array accessors diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 3c131b919..e845ec7cb 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1453,10 +1453,14 @@ (defknown %with-array-data (array index (or index null)) (values (simple-array * (*)) index index index) (foldable flushable)) +(defknown %with-array-data/fp (array index (or index null)) + (values (simple-array * (*)) index index index) + (foldable flushable)) (defknown %set-symbol-package (symbol t) t (unsafe)) (defknown %coerce-name-to-fun ((or symbol cons)) function (flushable)) (defknown %coerce-callable-to-fun (callable) function (flushable)) -(defknown failed-%with-array-data (t t t) nil) +(defknown bounding-index-error (t t t) nil) +(defknown bounding-index-error/fp (t t t) nil) (defknown %find-position (t sequence t index sequence-end function function) (values t (or index null)) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index d7dbab224..a7d55cd4d 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -284,13 +284,12 @@ (deftransform %check-vector-sequence-bounds ((vector start end) (vector * *) * :node node) - ;; FIXME: Should this not be INSERT-ARRAY-BOUNDS-CHECKS? - (if (policy node (< safety speed)) + (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) @@ -418,7 +417,8 @@ (values `(with-array-data ((data seq) (start start) - (end end)) + (end end) + :check-fill-pointer t) (declare (type (simple-array ,element-type 1) data)) (declare (type fixnum start end)) (do ((i start (1+ i))) @@ -1048,13 +1048,12 @@ end-arg element done-p-expr) - (with-unique-names (offset block index n-sequence sequence n-end end) - `(let ((,n-sequence ,sequence-arg) - (,n-end ,end-arg)) + (with-unique-names (offset block index n-sequence sequence end) + `(let* ((,n-sequence ,sequence-arg)) (with-array-data ((,sequence ,n-sequence :offset-var ,offset) (,start ,start) - (,end (%check-vector-sequence-bounds - ,n-sequence ,start ,n-end))) + (,end ,end-arg) + :check-fill-pointer t) (block ,block (macrolet ((maybe-return () ;; WITH-ARRAY-DATA has already performed bounds @@ -1062,10 +1061,10 @@ ;; in the inner loop. '(let ((,element (locally (declare (optimize (insert-array-bounds-checks 0))) (aref ,sequence ,index)))) - (when ,done-p-expr - (return-from ,block - (values ,element - (- ,index ,offset))))))) + (when ,done-p-expr + (return-from ,block + (values ,element + (- ,index ,offset))))))) (if ,from-end (loop for ,index ;; (If we aren't fastidious about declaring that @@ -1076,7 +1075,7 @@ from (1- ,end) downto ,start do (maybe-return)) (loop for ,index of-type index from ,start below ,end do - (maybe-return)))) + (maybe-return)))) (values nil nil)))))) (def!macro %find-position-vector-macro (item sequence @@ -1142,7 +1141,7 @@ "expand inline" (check-inlineability-of-find-position-if sequence from-end) '(%find-position-vector-macro item sequence - from-end start end key test)) + from-end start end key test)) ;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND, ;;; POSITION-IF, etc. diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp index 2145c2d58..a659be1d3 100644 --- a/tests/seq.impure.lisp +++ b/tests/seq.impure.lisp @@ -377,15 +377,18 @@ (svref x 0)) (assert (raises-error? (svrefalike #*0) type-error)) -;;; checks for uniform bounding index handling under SAFETY 3 code. +;;; checks for uniform bounding index handling. +;;; +;;; This used to be SAFETY 3 only, but bypassing these checks with +;;; above-zero speed when SPEED > SAFETY is not The SBCL Way. ;;; ;;; KLUDGE: not all in one big form because that causes SBCL to spend ;;; an absolute age trying to compile it. (defmacro sequence-bounding-indices-test (&body body) `(progn - (locally + (locally ;; See Issues 332 [and 333(!)] in the CLHS - (declare (optimize (safety 3))) + (declare (optimize (speed 3) (safety 1))) (let ((string (make-array 10 :fill-pointer 5 :initial-element #\a @@ -401,7 +404,7 @@ ,@(cdr body)))) (locally ;; See Issues 332 [and 333(!)] in the CLHS - (declare (optimize (safety 3))) + (declare (optimize (speed 3) (safety 1))) (let ((string (make-array 10 :fill-pointer 5 :initial-element #\a diff --git a/version.lisp-expr b/version.lisp-expr index 745b70116..79fcb0f31 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.4" +"1.0.12.5" -- 2.11.4.GIT