From: Paul Khuong <pvk@pvk.ca>
Date: Fri, 24 May 2013 17:07:35 +0000 (-0400)
Subject: Fix (aref vector (+ i constant)) with i negative on x86oids
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=5d3a728a1d9a91e7218fe53f12f96ab63b846810;p=sbcl.git

Fix (aref vector (+ i constant)) with i negative on x86oids

 * The VOPs for indexed access with constant offset take a fixnum
   index. Adjust fndb entries to reflect that.

 * Fix FOLD-INDEX-ADDRESSING: don't convert if the resulting index
   would be wider than a fixnum, and compute the new offset correctly
   for subtractions.

 * Test case by Douglas Katzman.
---

diff --git a/NEWS b/NEWS
index a2e9a56..6a36c16 100644
--- a/NEWS
+++ b/NEWS
@@ -73,6 +73,8 @@ changes relative to sbcl-1.1.7:
     about a constant NIL (similar for non-EQ-comparable catch tags).
   * bug fix: Referring to INLINE global functions as values should not result
     in a compilation failure. (lp#1035721)
+  * bug fix: Known-safe vector access on x86oids should not fail spuriously
+    when the index is of the form (+ x constant-positive-integer).
   * optimization: faster ISQRT on fixnums and small bignums
   * optimization: faster and smaller INTEGER-LENGTH on fixnums on x86-64.
   * optimization: On x86-64, the number of multi-byte NOP instructions used
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 1aef68d..5a4e4eb 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -1477,11 +1477,11 @@
   (movable foldable flushable dx-safe))
 (defknown data-vector-ref (simple-array index) t
   (foldable 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 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 37273c1..003dc37 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)
@@ -295,7 +295,7 @@
   ())
 #!+(or x86 x86-64)
 (defknown %bignum-set-with-offset
-  (bignum-type bignum-index (signed-byte 24) bignum-element-type)
+  (bignum-type fixnum (signed-byte 24) bignum-element-type)
   bignum-element-type (always-translatable))
 
 (defknown %digit-0-or-plusp (bignum-element-type) boolean
diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index c4044a3..7984b71 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)
+                   ;; the remaining argument must be a fixnum, otherwise we lose
+                   (csubtypep (lvar-type x) (specifier-type 'fixnum)))
+        (delay-ir1-transform :constraint)
         (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/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index e16ad55..6ffdf0a 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4567,3 +4567,10 @@
           (test (- x) y)
           (test (- most-positive-fixnum x) y)
           (test (+ most-negative-fixnum x) y))))))
+
+(test-util: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))
+                               (error "foo"))))))
+    (funcall f -31)))