0.8.7.6:

	Fix implementation of *-MOD32 and %LEA, as pointed out by Paul
	Dietz (on #lisp IRC) and APD (sbcl-devel 2004-01-04)
	... make %LEA a somewhat more generic operation; its BASE and
		INDEX arguments can now be any integers, not just 32-bit
		ones; SCALE and DISP are restricted to {1,2,4,8} and
		(SIGNED-BYTE 32) respectively.
	... write a modular-fun-optimizer for %LEA, cutting the integer
		arguments to the appropriate width; define a VOP for
		%LEA-MOD32.
	... add one of PFD's test cases to our test suite.

diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp
index 5e56a99..dedb74a 100644 (file)
--- a/src/compiler/x86/arith.lisp
+++ b/src/compiler/x86/arith.lisp
@@ -794,6 +794,82 @@
 
     DONE))
 
+(in-package "SB!C")
+
+(defknown %lea (integer integer (member 1 2 4 8) (signed-byte 32))
+  integer
+  (foldable flushable movable))
+
+(defoptimizer (%lea derive-type) ((base index scale disp))
+  (when (and (constant-lvar-p scale)
+            (constant-lvar-p disp))
+    (let ((scale (lvar-value scale))
+         (disp (lvar-value disp))
+         (base-type (lvar-type base))
+         (index-type (lvar-type index)))
+      (when (and (numeric-type-p base-type)
+                (numeric-type-p index-type))
+       (let ((base-lo (numeric-type-low base-type))
+             (base-hi (numeric-type-high base-type))
+             (index-lo (numeric-type-low index-type))
+             (index-hi (numeric-type-high index-type)))
+         (make-numeric-type :class 'integer
+                            :complexp :real
+                            :low (when (and base-lo index-lo)
+                                   (+ base-lo (* index-lo scale) disp))
+                            :high (when (and base-hi index-hi)
+                                    (+ base-hi (* index-hi scale) disp))))))))
+
+(defun %lea (base index scale disp)
+  (+ base (* index scale) disp))
+
+(in-package "SB!VM")
+
+(define-vop (%lea/unsigned=>unsigned)
+  (:translate %lea)
+  (:policy :fast-safe)
+  (:args (base :scs (unsigned-reg))
+        (index :scs (unsigned-reg)))
+  (:info scale disp)
+  (:arg-types unsigned-num unsigned-num
+             (:constant (member 1 2 4 8))
+             (:constant (signed-byte 32)))
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:generator 5
+    (inst lea r (make-ea :dword :base base :index index
+                        :scale scale :disp disp))))
+
+(define-vop (%lea/signed=>signed)
+  (:translate %lea)
+  (:policy :fast-safe)
+  (:args (base :scs (signed-reg))
+        (index :scs (signed-reg)))
+  (:info scale disp)
+  (:arg-types signed-num signed-num
+             (:constant (member 1 2 4 8))
+             (:constant (signed-byte 32)))
+  (:results (r :scs (signed-reg)))
+  (:result-types signed-num)
+  (:generator 4
+    (inst lea r (make-ea :dword :base base :index index
+                        :scale scale :disp disp))))
+
+(define-vop (%lea/fixnum=>fixnum)
+  (:translate %lea)
+  (:policy :fast-safe)
+  (:args (base :scs (any-reg))
+        (index :scs (any-reg)))
+  (:info scale disp)
+  (:arg-types tagged-num tagged-num
+             (:constant (member 1 2 4 8))
+             (:constant (signed-byte 32)))
+  (:results (r :scs (any-reg)))
+  (:result-types tagged-num)
+  (:generator 3
+    (inst lea r (make-ea :dword :base base :index index
+                        :scale scale :disp disp))))
+
 ;;; FIXME: before making knowledge of this too public, it needs to be
 ;;; fixed so that it's actually _faster_ than the non-CMOV version; at
 ;;; least on my Celeron-XXX laptop, this version is marginally slower
@@ -1163,6 +1239,26 @@
              fast-ash-c/unsigned=>unsigned)
   (:translate ash-left-mod32))
 
+(in-package "SB!C")
+
+(defknown sb!vm::%lea-mod32 (integer integer (member 1 2 4 8) (signed-byte 32))
+  (unsigned-byte 32)
+  (foldable flushable movable))
+
+(define-modular-fun-optimizer %lea ((base index scale disp) :width width)
+  (when (and (<= width 32)
+            (constant-lvar-p scale)
+            (constant-lvar-p disp))
+    (cut-to-width base width)
+    (cut-to-width index width)
+    'sb!vm::%lea-mod32))
+
+(in-package "SB!VM")
+
+(define-vop (%lea-mod32/unsigned=>unsigned
+            %lea/unsigned=>unsigned)
+  (:translate %lea-mod32))
+
 ;;; logical operations
 (define-modular-fun lognot-mod32 (x) lognot 32)
 (define-vop (lognot-mod32/unsigned=>unsigned)
@@ -1511,84 +1607,6 @@
 
 (in-package "SB!C")
 
-(defknown %lea ((or (signed-byte 32) (unsigned-byte 32))
-               (or (signed-byte 32) (unsigned-byte 32))
-               (member 1 2 4 8) (signed-byte 32))
-  (or (signed-byte 32) (unsigned-byte 32))
-  (foldable flushable))
-
-(defoptimizer (%lea derive-type) ((base index scale disp))
-  (when (and (constant-lvar-p scale)
-            (constant-lvar-p disp))
-    (let ((scale (lvar-value scale))
-         (disp (lvar-value disp))
-         (base-type (lvar-type base))
-         (index-type (lvar-type index)))
-      (when (and (numeric-type-p base-type)
-                (numeric-type-p index-type))
-       (let ((base-lo (numeric-type-low base-type))
-             (base-hi (numeric-type-high base-type))
-             (index-lo (numeric-type-low index-type))
-             (index-hi (numeric-type-high index-type)))
-         (make-numeric-type :class 'integer
-                            :complexp :real
-                            :low (when (and base-lo index-lo)
-                                   (+ base-lo (* index-lo scale) disp))
-                            :high (when (and base-hi index-hi)
-                                    (+ base-hi (* index-hi scale) disp))))))))
-
-(defun %lea (base index scale disp)
-  (+ base (* index scale) disp))
-
-(in-package "SB!VM")
-
-(define-vop (%lea/unsigned=>unsigned)
-  (:translate %lea)
-  (:policy :fast-safe)
-  (:args (base :scs (unsigned-reg))
-        (index :scs (unsigned-reg)))
-  (:info scale disp)
-  (:arg-types unsigned-num unsigned-num
-             (:constant (member 1 2 4 8))
-             (:constant (signed-byte 32)))
-  (:results (r :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:generator 5
-    (inst lea r (make-ea :dword :base base :index index
-                        :scale scale :disp disp))))
-
-(define-vop (%lea/signed=>signed)
-  (:translate %lea)
-  (:policy :fast-safe)
-  (:args (base :scs (signed-reg))
-        (index :scs (signed-reg)))
-  (:info scale disp)
-  (:arg-types signed-num signed-num
-             (:constant (member 1 2 4 8))
-             (:constant (signed-byte 32)))
-  (:results (r :scs (signed-reg)))
-  (:result-types signed-num)
-  (:generator 4
-    (inst lea r (make-ea :dword :base base :index index
-                        :scale scale :disp disp))))
-
-(define-vop (%lea/fixnum=>fixnum)
-  (:translate %lea)
-  (:policy :fast-safe)
-  (:args (base :scs (any-reg))
-        (index :scs (any-reg)))
-  (:info scale disp)
-  (:arg-types tagged-num tagged-num
-             (:constant (member 1 2 4 8))
-             (:constant (signed-byte 32)))
-  (:results (r :scs (any-reg)))
-  (:result-types tagged-num)
-  (:generator 3
-    (inst lea r (make-ea :dword :base base :index index
-                        :scale scale :disp disp))))
-
-(in-package "SB!C")
-
 ;;; This is essentially a straight implementation of the algorithm in
 ;;; "Strength Reduction of Multiplications by Integer Constants",
 ;;; Youfeng Wu, ACM SIGPLAN Notices, Vol. 30, No.2, February 1995.

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 96e1c8f..4a0bf41 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1019,3 +1019,16 @@
                    (dotimes (iv4 5 a) (%f9 0 0 b)))
                  0)))
           1 2)))
+
+;;; MISC.259-264 (aka "CSR screwed up implementing *-MOD32")
+(assert
+ (= (funcall
+     (compile
+      nil
+      '(lambda (a)
+         (declare (type (integer 177547470 226026978) a))
+         (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)
+                            (compilation-speed 1)))
+         (logand a (* a 438810))))
+     215067723)
+    13739018))
\ No newline at end of file

diff --git a/version.lisp-expr b/version.lisp-expr
index 1de180f..40ff5e8 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".)
-"0.8.7.5"
+"0.8.7.6"