From: Eric Marsden Date: Mon, 31 Oct 2011 12:34:39 +0000 (+0200) Subject: fix SEARCH vector vector transform X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=e981481e65e869a92420616163b2ba3ec68b25d7;p=sbcl.git fix SEARCH vector vector transform Didn't handle empty sequences correctly. Didn't handle NIL as KEY correctly. --- diff --git a/NEWS b/NEWS index 9f2db4e..88709b9 100644 --- a/NEWS +++ b/NEWS @@ -27,6 +27,8 @@ changes relative to sbcl-1.0.52: on 64 bit platforms. (lp#881445) * bug fix: DELETE-FILE did not MERGE-PATHNAMES, making it possible to delete the wrong file when using relative pathnames. (lp#882877) + * bug fix: optimized SEARCH of vectors-on-vectors mishandled zero-length + sequences and :KEY NIL. changes in sbcl-1.0.52 relative to sbcl-1.0.51: * enhancement: ASDF has been updated to version 2.017. diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index d086e3e..9b9db97 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -1055,60 +1055,78 @@ :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 (= 0 end1) + (return-from search 0)) + (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 diff --git a/tests/seq.pure.lisp b/tests/seq.pure.lisp index 2c1d638..3819f41 100644 --- a/tests/seq.pure.lisp +++ b/tests/seq.pure.lisp @@ -250,3 +250,44 @@ ;; element is found before that's an issue. (assert (eq :foo (find :foo '(1 2 3 :foo) :start 1 :end 5))) (assert (= 3 (position :foo '(1 2 3 :foo) :start 1 :end 5)))) + +(with-test (:name (:search :empty-seq)) + (assert (eql 0 + (funcall (compile nil + `(lambda (x) + (declare (optimize (speed 3)) (simple-vector x)) + (search x #()))) + #()))) + (assert (eql 0 + (funcall (compile nil + `(lambda (x) + (declare (optimize (speed 3)) (simple-vector x)) + (search x #(t t t)))) + #()))) + (assert (eql 0 + (funcall (compile nil + `(lambda (x) + (declare (optimize (speed 3)) (simple-vector x)) + (search x #(t t t) :end1 0))) + #(t t t)))) + (assert (eql 0 + (funcall (compile nil + `(lambda (x) + (declare (optimize (speed 3)) (simple-vector x)) + (search x #(t t t) :key nil))) + #()))) + (assert (eql 0 + (funcall (compile nil + `(lambda (x k) + (declare (optimize (speed 3)) (simple-vector x)) + (search x #(t t t) :key k))) + #() nil))) + (assert (eq :ok + (handler-case + (funcall (compile nil + `(lambda (x) + (declare (optimize (speed 3)) (simple-vector x)) + (search x #(t t t) :start2 1 :end2 0 :end1 0))) + #(t t t)) + (sb-kernel:bounding-indices-bad-error () + :ok)))))