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

This reverts commit 5d3a728a1d9a91e7218fe53f12f96ab63b846810.

The current code is still wrong, but better the bugs we've always had
than the ones that break currently-working code.

Kept the test case, and added the one we failed on.

diff --git a/NEWS b/NEWS
index 6a36c16..a2e9a56 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -73,8 +73,6 @@ 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)
     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
   * 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 5a4e4eb..1aef68d 100644 (file)
--- 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))
   (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 fixnum fixnum) t
+(defknown data-vector-ref-with-offset (simple-array index fixnum) t

   (foldable explicit-check always-translatable))
 (defknown data-vector-set (array index t) t
   (explicit-check always-translatable))
   (foldable explicit-check always-translatable))
 (defknown data-vector-set (array index t) t
   (explicit-check always-translatable))

-(defknown data-vector-set-with-offset (array fixnum fixnum t) t
+(defknown data-vector-set-with-offset (array index fixnum t) t

   (explicit-check always-translatable))
 (defknown hairy-data-vector-ref (array index) t
   (foldable explicit-check))
   (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 003dc37..37273c1 100644 (file)
--- 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 (bignum-type bignum-index) bignum-element-type
   (flushable))
 #!+(or x86 x86-64)

-(defknown %bignum-ref-with-offset (bignum-type fixnum (signed-byte 24))
+(defknown %bignum-ref-with-offset (bignum-type bignum-index (signed-byte 24))

   bignum-element-type (flushable always-translatable))
 
 (defknown %bignum-set (bignum-type bignum-index bignum-element-type)
   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
   ())
 #!+(or x86 x86-64)
 (defknown %bignum-set-with-offset

-  (bignum-type fixnum (signed-byte 24) bignum-element-type)
+  (bignum-type bignum-index (signed-byte 24) bignum-element-type)

   bignum-element-type (always-translatable))
 
 (defknown %digit-0-or-plusp (bignum-element-type) boolean
   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 7984b71..c4044a3 100644 (file)
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -50,24 +50,20 @@
                               index offset &optional setter-p)
   (multiple-value-bind (func index-args) (extract-fun-args index '(+ -) 2)
     (destructuring-bind (x constant) index-args
                               index offset &optional setter-p)
   (multiple-value-bind (func index-args) (extract-fun-args index '(+ -) 2)
     (destructuring-bind (x constant) index-args

-      (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)
+      (declare (ignorable x))
+      (unless (constant-lvar-p constant)

         (give-up-ir1-transform))
         (give-up-ir1-transform))

-      (let ((value (lvar-value constant))
-            new-offset)
+      (let ((value (lvar-value constant)))

         (unless (and (integerp value)
                      (sb!vm::foldable-constant-offset-p
                       element-size lowtag data-offset
         (unless (and (integerp value)
                      (sb!vm::foldable-constant-offset-p
                       element-size lowtag data-offset

-                      (setf new-offset (funcall func (lvar-value offset) value))))
+                      (funcall func value (lvar-value offset))))

           (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)))
           (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)))

-           (declare (ignore off1 off2))
-           (,fun-name thing index ',new-offset ,@(when setter-p
-                                                   '(value))))))))
+           (,fun-name thing index (,func off2 off1) ,@(when setter-p
+                                                        '(value))))))))

 
 #!+(or x86 x86-64)
 (deftransform sb!bignum:%bignum-ref-with-offset
 
 #!+(or x86 x86-64)
 (deftransform sb!bignum:%bignum-ref-with-offset

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 6ffdf0a..bccf8ef 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4568,9 +4568,19 @@
           (test (- most-positive-fixnum x) y)
           (test (+ most-negative-fixnum x) y))))))
 
           (test (- most-positive-fixnum x) y)
           (test (+ most-negative-fixnum x) y))))))
 

-(test-util:with-test (:name :fold-index-addressing-positive-offset)
+;; expected failure
+(test-util:with-test (:name :fold-index-addressing-positive-offset
+                      :fails-on '(and))

   (let ((f (compile nil `(lambda (i)
                            (if (typep i '(integer -31 31))
                                (aref #. (make-array 63) (+ i 31))
                                (error "foo"))))))
     (funcall f -31)))
   (let ((f (compile nil `(lambda (i)
                            (if (typep i '(integer -31 31))
                                (aref #. (make-array 63) (+ i 31))
                                (error "foo"))))))
     (funcall f -31)))

+
+;; 5d3a728 broke something like this in CL-PPCRE
+(test-util: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))))))))