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
(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))
(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)
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
(: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)))
(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)
(: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)))
(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)
(: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)))
(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)
(: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)))
(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)
(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)
(: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))
(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)
(: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)))
(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)
(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)))
(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)
(: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)))
(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)
(: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)))
(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)
(: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))
(: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)
(: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))
(: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)
(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)))
(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))
(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))))))
projects / sbcl.git / commitdiff