From a3b10e4bd291d1b07cb805a58cf8fe03156bdb3b Mon Sep 17 00:00:00 2001 From: Paul Khuong Date: Sat, 8 Jun 2013 01:39:10 -0400 Subject: [PATCH] Handle (aref v (+ i k)), with i negative * Update the fndb to allow negative index values for foo-ref-with-offset and foo-set-with-offset. * Adjust VOPs accordingly. * Fix fold-index-addressing: only fold constant offsets if the resulting index argument would be a fixnum, and compute the new offset correctly for subtractions. * Unmark the corresponding test as an expected feailure, and add a test to make sure VOPs for data-vector-{ref,set}-with-offset accept negative index values (unless the element size is too small to fold offsets in an EA). * Un-package-qualify a few spurious test-util:with-test. --- NEWS | 4 ++- src/compiler/fndb.lisp | 4 +-- src/compiler/generic/vm-fndb.lisp | 2 +- src/compiler/generic/vm-tran.lisp | 16 +++++++----- src/compiler/x86-64/array.lisp | 22 ++++++++--------- src/compiler/x86/array.lisp | 32 ++++++++++++------------ tests/compiler.pure.lisp | 49 +++++++++++++++++++++++++++++++------ 7 files changed, 85 insertions(+), 44 deletions(-) diff --git a/NEWS b/NEWS index c65f72e..6a48d94 100644 --- a/NEWS +++ b/NEWS @@ -34,7 +34,9 @@ changes relative to sbcl-1.1.8: reported by Eric Marsden) * bug fix: FP return values from foreign calls are always rounded to single or double float precision on x87. - + * bug fix: Known-safe vector access on x86oids should not fail spuriously + when the index is of the form (+ x constant-positive-integer). + changes in sbcl-1.1.8 relative to sbcl-1.1.7: * notice: The implementation of MAP-ALLOCATED-OBJECTS (the heart of ROOM, plus a few SB-INTROSPECT functions) has been completely diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 30fc30b..c35e93a 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1473,11 +1473,11 @@ (movable foldable flushable dx-safe)) (defknown data-vector-ref (simple-array index) t (foldable unsafely-flushable explicit-check always-translatable)) -(defknown data-vector-ref-with-offset (simple-array index fixnum) t +(defknown data-vector-ref-with-offset (simple-array fixnum fixnum) t (foldable unsafely-flushable explicit-check always-translatable)) (defknown data-vector-set (array index t) t (explicit-check always-translatable)) -(defknown data-vector-set-with-offset (array index fixnum t) t +(defknown data-vector-set-with-offset (array fixnum fixnum t) t (explicit-check always-translatable)) (defknown hairy-data-vector-ref (array index) t (foldable explicit-check)) diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index 70ce7de..8e7092b 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -287,7 +287,7 @@ (defknown %bignum-ref (bignum-type bignum-index) bignum-element-type (flushable)) #!+(or x86 x86-64) -(defknown %bignum-ref-with-offset (bignum-type bignum-index (signed-byte 24)) +(defknown %bignum-ref-with-offset (bignum-type fixnum (signed-byte 24)) bignum-element-type (flushable always-translatable)) (defknown %bignum-set (bignum-type bignum-index bignum-element-type) diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index c4044a3..256ead3 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -50,20 +50,24 @@ index offset &optional setter-p) (multiple-value-bind (func index-args) (extract-fun-args index '(+ -) 2) (destructuring-bind (x constant) index-args - (declare (ignorable x)) - (unless (constant-lvar-p constant) + (unless (and (constant-lvar-p constant) + ;; we lose if the remaining argument isn't a fixnum + (csubtypep (lvar-type x) (specifier-type 'fixnum))) (give-up-ir1-transform)) - (let ((value (lvar-value constant))) + (let ((value (lvar-value constant)) + new-offset) (unless (and (integerp value) (sb!vm::foldable-constant-offset-p element-size lowtag data-offset - (funcall func value (lvar-value offset)))) + (setf new-offset (funcall func (lvar-value offset) + value)))) (give-up-ir1-transform "constant is too large for inlining")) (splice-fun-args index func 2) `(lambda (thing index off1 off2 ,@(when setter-p '(value))) - (,fun-name thing index (,func off2 off1) ,@(when setter-p - '(value)))))))) + (declare (ignore off1 off2)) + (,fun-name thing index ',new-offset ,@(when setter-p + '(value)))))))) #!+(or x86 x86-64) (deftransform sb!bignum:%bignum-ref-with-offset diff --git a/src/compiler/x86-64/array.lisp b/src/compiler/x86-64/array.lisp index 7ba5839..4923793 100644 --- a/src/compiler/x86-64/array.lisp +++ b/src/compiler/x86-64/array.lisp @@ -353,7 +353,7 @@ (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) (:info offset) - (:arg-types simple-array-single-float positive-fixnum + (:arg-types simple-array-single-float tagged-num (:constant (constant-displacement other-pointer-lowtag 4 vector-data-offset))) ,@(when use-temp '((:temporary (:sc unsigned-reg) dword-index))) @@ -391,7 +391,7 @@ (index :scs (any-reg)) (value :scs (single-reg) :target result)) (:info offset) - (:arg-types simple-array-single-float positive-fixnum + (:arg-types simple-array-single-float tagged-num (:constant (constant-displacement other-pointer-lowtag 4 vector-data-offset)) single-float) @@ -431,7 +431,7 @@ (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) (:info offset) - (:arg-types simple-array-double-float positive-fixnum + (:arg-types simple-array-double-float tagged-num (:constant (constant-displacement other-pointer-lowtag 8 vector-data-offset))) (:results (value :scs (double-reg))) @@ -462,7 +462,7 @@ (index :scs (any-reg)) (value :scs (double-reg) :target result)) (:info offset) - (:arg-types simple-array-double-float positive-fixnum + (:arg-types simple-array-double-float tagged-num (:constant (constant-displacement other-pointer-lowtag 8 vector-data-offset)) double-float) @@ -501,7 +501,7 @@ (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) (:info offset) - (:arg-types simple-array-complex-single-float positive-fixnum + (:arg-types simple-array-complex-single-float tagged-num (:constant (constant-displacement other-pointer-lowtag 8 vector-data-offset))) (:results (value :scs (complex-single-reg))) @@ -532,7 +532,7 @@ (index :scs (any-reg)) (value :scs (complex-single-reg) :target result)) (:info offset) - (:arg-types simple-array-complex-single-float positive-fixnum + (:arg-types simple-array-complex-single-float tagged-num (:constant (constant-displacement other-pointer-lowtag 8 vector-data-offset)) complex-single-float) @@ -568,7 +568,7 @@ (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) (:info offset) - (:arg-types simple-array-complex-double-float positive-fixnum + (:arg-types simple-array-complex-double-float tagged-num (:constant (constant-displacement other-pointer-lowtag 16 vector-data-offset))) (:results (value :scs (complex-double-reg))) @@ -599,7 +599,7 @@ (index :scs (any-reg)) (value :scs (complex-double-reg) :target result)) (:info offset) - (:arg-types simple-array-complex-double-float positive-fixnum + (:arg-types simple-array-complex-double-float tagged-num (:constant (constant-displacement other-pointer-lowtag 16 vector-data-offset)) complex-double-float) @@ -640,7 +640,7 @@ (multiple-value-bind (index-sc scale) (if (>= n-bytes (ash 1 n-fixnum-tag-bits)) (values 'any-reg (ash n-bytes (- n-fixnum-tag-bits))) - (values 'unsigned-reg n-bytes)) + (values 'signed-reg n-bytes)) `(progn (define-vop (,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" ptype)) (:translate data-vector-ref-with-offset) @@ -648,7 +648,7 @@ (:args (object :scs (descriptor-reg)) (index :scs (,index-sc))) (:info offset) - (:arg-types ,ptype positive-fixnum + (:arg-types ,ptype tagged-num (:constant (constant-displacement other-pointer-lowtag ,n-bytes vector-data-offset))) (:results (value :scs ,scs)) @@ -683,7 +683,7 @@ (index :scs (,index-sc) :to (:eval 0)) (value :scs ,scs :target result)) (:info offset) - (:arg-types ,ptype positive-fixnum + (:arg-types ,ptype tagged-num (:constant (constant-displacement other-pointer-lowtag ,n-bytes vector-data-offset)) ,type) diff --git a/src/compiler/x86/array.lisp b/src/compiler/x86/array.lisp index 1b6c8f2..ecd91fd 100644 --- a/src/compiler/x86/array.lisp +++ b/src/compiler/x86/array.lisp @@ -321,7 +321,7 @@ (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate))) (:info offset) - (:arg-types simple-array-single-float positive-fixnum + (:arg-types simple-array-single-float tagged-num (:constant (constant-displacement other-pointer-lowtag 4 vector-data-offset))) (:results (value :scs (single-reg))) @@ -338,7 +338,7 @@ (index :scs (any-reg immediate)) (value :scs (single-reg) :target result)) (:info offset) - (:arg-types simple-array-single-float positive-fixnum + (:arg-types simple-array-single-float tagged-num (:constant (constant-displacement other-pointer-lowtag 4 vector-data-offset)) single-float) @@ -372,7 +372,7 @@ (index :scs (any-reg immediate))) (:info offset) (:arg-types simple-array-double-float - positive-fixnum + tagged-num (:constant (constant-displacement other-pointer-lowtag 8 vector-data-offset))) (:results (value :scs (double-reg))) @@ -389,7 +389,7 @@ (index :scs (any-reg immediate)) (value :scs (double-reg) :target result)) (:info offset) - (:arg-types simple-array-double-float positive-fixnum + (:arg-types simple-array-double-float tagged-num (:constant (constant-displacement other-pointer-lowtag 8 vector-data-offset)) double-float) @@ -424,7 +424,7 @@ (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate))) (:info offset) - (:arg-types simple-array-complex-single-float positive-fixnum + (:arg-types simple-array-complex-single-float tagged-num (:constant (constant-displacement other-pointer-lowtag 8 vector-data-offset))) (:results (value :scs (complex-single-reg))) @@ -447,7 +447,7 @@ (index :scs (any-reg immediate)) (value :scs (complex-single-reg) :target result)) (:info offset) - (:arg-types simple-array-complex-single-float positive-fixnum + (:arg-types simple-array-complex-single-float tagged-num (:constant (constant-displacement other-pointer-lowtag 8 vector-data-offset)) complex-single-float) @@ -490,7 +490,7 @@ (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate))) (:info offset) - (:arg-types simple-array-complex-double-float positive-fixnum + (:arg-types simple-array-complex-double-float tagged-num (:constant (constant-displacement other-pointer-lowtag 16 vector-data-offset))) (:results (value :scs (complex-double-reg))) @@ -512,7 +512,7 @@ (index :scs (any-reg immediate)) (value :scs (complex-double-reg) :target result)) (:info offset) - (:arg-types simple-array-complex-double-float positive-fixnum + (:arg-types simple-array-complex-double-float tagged-num (:constant (constant-displacement other-pointer-lowtag 16 vector-data-offset)) complex-double-float) @@ -560,9 +560,9 @@ (:translate data-vector-ref-with-offset) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg immediate))) + (index :scs (signed-reg immediate))) (:info offset) - (:arg-types ,ptype positive-fixnum + (:arg-types ,ptype tagged-num (:constant (constant-displacement other-pointer-lowtag 1 vector-data-offset))) (:results (value :scs ,scs)) @@ -581,11 +581,11 @@ (:translate data-vector-set-with-offset) (:policy :fast-safe) (:args (object :scs (descriptor-reg) :to (:eval 0)) - (index :scs (unsigned-reg immediate) :to (:eval 0)) + (index :scs (signed-reg immediate) :to (:eval 0)) (value :scs ,scs ,@(unless 8-bit-tns-p '(:target eax)))) (:info offset) - (:arg-types ,ptype positive-fixnum + (:arg-types ,ptype tagged-num (:constant (constant-displacement other-pointer-lowtag 1 vector-data-offset)) ,element-type) @@ -631,9 +631,9 @@ (:translate data-vector-ref-with-offset) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg immediate))) + (index :scs (signed-reg immediate))) (:info offset) - (:arg-types ,ptype positive-fixnum + (:arg-types ,ptype tagged-num (:constant (constant-displacement other-pointer-lowtag 2 vector-data-offset))) (:results (value :scs ,scs)) @@ -652,10 +652,10 @@ (:translate data-vector-set-with-offset) (:policy :fast-safe) (:args (object :scs (descriptor-reg) :to (:eval 0)) - (index :scs (unsigned-reg immediate) :to (:eval 0)) + (index :scs (signed-reg immediate) :to (:eval 0)) (value :scs ,scs :target eax)) (:info offset) - (:arg-types ,ptype positive-fixnum + (:arg-types ,ptype tagged-num (:constant (constant-displacement other-pointer-lowtag 2 vector-data-offset)) ,element-type) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 0978121..48ccbb1 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -3089,7 +3089,7 @@ (array-in-bounds-p a 5 2)))))) ;;; optimizing (EXPT -1 INTEGER) -(test-util:with-test (:name (expt minus-one integer)) +(with-test (:name (expt minus-one integer)) (dolist (x '(-1 -1.0 -1.0d0)) (let ((fun (compile nil `(lambda (x) (expt ,x (the fixnum x)))))) (assert (not (ctu:find-named-callees fun))) @@ -4578,8 +4578,7 @@ (test (+ most-negative-fixnum x) y)))))) ;; expected failure -(test-util:with-test (:name :fold-index-addressing-positive-offset - :fails-on '(and)) +(with-test (:name :fold-index-addressing-positive-offset) (let ((f (compile nil `(lambda (i) (if (typep i '(integer -31 31)) (aref #. (make-array 63) (+ i 31)) @@ -4587,28 +4586,64 @@ (funcall f -31))) ;; 5d3a728 broke something like this in CL-PPCRE -(test-util:with-test (:name :fold-index-addressing-potentially-negative-index) +(with-test (:name :fold-index-addressing-potentially-negative-index) (compile nil `(lambda (index vector) (declare (optimize speed (safety 0)) ((simple-array character (*)) vector) ((unsigned-byte 24) index)) (aref vector (1+ (mod index (1- (length vector)))))))) -(test-util:with-test (:name :constant-fold-ash/right-fixnum) +(with-test (:name :constant-fold-ash/right-fixnum) (compile nil `(lambda (a b) (declare (type fixnum a) (type (integer * -84) b)) (ash a b)))) -(test-util:with-test (:name :constant-fold-ash/right-word) +(with-test (:name :constant-fold-ash/right-word) (compile nil `(lambda (a b) (declare (type word a) (type (integer * -84) b)) (ash a b)))) -(test-util:with-test (:name :nconc-derive-type) +(with-test (:name :nconc-derive-type) (let ((function (compile nil `(lambda (x y) (declare (type (or cons fixnum) x)) (nconc x y))))) (assert (equal (sb-kernel:%simple-fun-type function) '(function ((or cons fixnum) t) (values cons &optional)))))) + +;; make sure that all data-vector-ref-with-offset VOPs are either +;; specialised on a 0 offset or accept signed indices +(with-test (:name :data-vector-ref-with-offset-signed-index) + (let ((dvr (find-symbol "DATA-VECTOR-REF-WITH-OFFSET" "SB-KERNEL"))) + (when dvr + (assert + (null + (loop for info in (sb-c::fun-info-templates + (sb-c::fun-info-or-lose dvr)) + for (nil second-arg third-arg) = (sb-c::vop-info-arg-types info) + unless (or (typep second-arg '(cons (eql :constant))) + (find '(integer 0 0) third-arg :test 'equal) + (equal second-arg + `(:or ,(sb-c::primitive-type-or-lose + 'sb-vm::positive-fixnum) + ,(sb-c::primitive-type-or-lose + 'fixnum)))) + collect info)))))) + +(with-test (:name :data-vector-set-with-offset-signed-index) + (let ((dvr (find-symbol "DATA-VECTOR-SET-WITH-OFFSET" "SB-KERNEL"))) + (when dvr + (assert + (null + (loop for info in (sb-c::fun-info-templates + (sb-c::fun-info-or-lose dvr)) + for (nil second-arg third-arg) = (sb-c::vop-info-arg-types info) + unless (or (typep second-arg '(cons (eql :constant))) + (find '(integer 0 0) third-arg :test 'equal) + (equal second-arg + `(:or ,(sb-c::primitive-type-or-lose + 'sb-vm::positive-fixnum) + ,(sb-c::primitive-type-or-lose + 'fixnum)))) + collect info)))))) -- 1.7.10.4