1.0.9.58: Fix x86 smod30 ash with a constant large argument.

	The usual thing: the VOP was written in the belief that the
	compiler had already proved that the shift couldn't be
	too large.

	(Include test cases which should catch the analogous problem on
	x86-64 as well as the problem just fixed.)

diff --git a/NEWS b/NEWS
index 6963b3f..33cdc48 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -29,6 +29,8 @@ changes in sbcl-1.0.10 relative to sbcl-1.0.9:
     the CAS operation was being performed.
   * bug fix: copy propagation interfered with parallel assignment
     semantics in local calls. (reported by Paul Khuong)
+  * bug fix: the signed modular fixnum shift compiled to wrong code on
+    x86.  (spotted by a slight modification to some of PFD's tests)
 
 changes in sbcl-1.0.9 relative to sbcl-1.0.8:
   * minor incompatible change: SB-SYS:OUTPUT-RAW-BYTES is deprecated.

diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp
index 1e86a0b..7511b32 100644 (file)
--- a/src/compiler/x86/arith.lisp
+++ b/src/compiler/x86/arith.lisp
@@ -604,17 +604,20 @@
            (inst lea result (make-ea :dword :index number :scale 8)))
           (t
            (move result number)
-           (cond ((plusp amount)
-                  ;; We don't have to worry about overflow because of the
-                  ;; result type restriction.
-                  (inst shl result amount))
-                 (t
-                  ;; If the amount is greater than 31, only shift by 31. We
-                  ;; have to do this because the shift instructions only look
-                  ;; at the low five bits of the result.
-                  (inst sar result (min 31 (- amount)))
-                  ;; Fixnum correction.
-                  (inst and result (lognot fixnum-tag-mask))))))))
+           (cond ((< -32 amount 32)
+                  ;; this code is used both in ASH and ASH-SMOD30, so
+                  ;; be careful
+                  (if (plusp amount)
+                      (inst shl result amount)
+                      (progn
+                        (inst sar result (- amount))
+                        (inst and result (lognot fixnum-tag-mask)))))
+                 ((plusp amount)
+                  (if (sc-is result any-reg)
+                      (inst xor result result)
+                      (inst mov result 0)))
+                 (t (inst sar result 31)
+                    (inst and result (lognot fixnum-tag-mask))))))))
 
 (define-vop (fast-ash-left/fixnum=>fixnum)
   (:translate ash)

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 5448102..5d12ac0 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -774,6 +774,35 @@
                          (declare (type (integer 4303063 101130078) a))
                          (mask-field (byte 18 2) (ash a 77))))
               57132532)))
+;;; rewrite the test case to get the unsigned-byte 32/64
+;;; implementation even after implementing some modular arithmetic
+;;; with signed-byte 30:
+(assert (= 0 (funcall
+              (compile nil
+                       '(lambda (a)
+                         (declare (type (integer 4303063 101130078) a))
+                         (mask-field (byte 30 2) (ash a 77))))
+              57132532)))
+(assert (= 0 (funcall
+              (compile nil
+                       '(lambda (a)
+                         (declare (type (integer 4303063 101130078) a))
+                         (mask-field (byte 64 2) (ash a 77))))
+              57132532)))
+;;; and a similar test case for the signed masking extension (not the
+;;; final interface, so change the call when necessary):
+(assert (= 0 (funcall
+              (compile nil
+                       '(lambda (a)
+                         (declare (type (integer 4303063 101130078) a))
+                         (sb-c::mask-signed-field 30 (ash a 77))))
+              57132532)))
+(assert (= 0 (funcall
+              (compile nil
+                       '(lambda (a)
+                         (declare (type (integer 4303063 101130078) a))
+                         (sb-c::mask-signed-field 61 (ash a 77))))
+              57132532)))
 
 ;;; MISC.101 and MISC.103: FLUSH-DEST did not mark the USE's block for
 ;;; type check regeneration

diff --git a/version.lisp-expr b/version.lisp-expr
index a58d511..1564240 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.9.57"
+"1.0.9.58"