From 787090e008e13b1c91ba04cf7776ca0af7336342 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sun, 4 Jan 2004 17:43:06 +0000 Subject: [PATCH] 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. --- src/compiler/x86/arith.lisp | 174 ++++++++++++++++++++++++------------------- tests/compiler.pure.lisp | 13 ++++ version.lisp-expr | 2 +- 3 files changed, 110 insertions(+), 79 deletions(-) diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp index 5e56a99..dedb74a 100644 --- 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 --- 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 --- 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" -- 1.7.10.4