From bf69a011740c082566642b2335a9968b441cadec Mon Sep 17 00:00:00 2001 From: Lutz Euler Date: Mon, 23 Apr 2012 22:11:05 +0200 Subject: [PATCH] Allow larger immediate values in fixnum arithmetic on x86-64. Arithmetic on tagged fixnums currently assembles only constant fixnums of type (SIGNED-BYTE 29) as immediate arguments to the machine instructions. When N-FIXNUM-TAG-BITS is less than 3 a larger range of fixnums could be treated this way. This is desirable as it avoids the costs of the alternative, namely to put the value into the constant pool. So change this type to (SIGNED-BYTE (- 32 N-FIXNUM-TAG-BITS)). Extend an existing test to cover constants in this range, too. Many thanks to Paul Khuong for help in finding a name for the type. --- src/compiler/x86-64/arith.lisp | 30 ++++++++++++++++++------------ tests/arith.pure.lisp | 34 +++++++++++++++++++++------------- 2 files changed, 39 insertions(+), 25 deletions(-) diff --git a/src/compiler/x86-64/arith.lisp b/src/compiler/x86-64/arith.lisp index b8ee90c..9d48e29 100644 --- a/src/compiler/x86-64/arith.lisp +++ b/src/compiler/x86-64/arith.lisp @@ -11,6 +11,12 @@ (in-package "SB!VM") + +;; A fixnum that can be represented in tagged form by a signed 32-bit +;; value and that can therefore be used as an immediate argument of +;; arithmetic machine instructions. +(deftype short-tagged-num () '(signed-byte #.(- 32 n-fixnum-tag-bits))) + ;;;; unary operations (define-vop (fast-safe-arith-op) @@ -110,13 +116,13 @@ (define-vop (fast-fixnum-binop-c fast-safe-arith-op) (:args (x :target r :scs (any-reg) - :load-if (or (not (typep y '(signed-byte 29))) + :load-if (or (not (typep y 'short-tagged-num)) (not (sc-is x any-reg control-stack))))) (:info y) (:arg-types tagged-num (:constant fixnum)) (:results (r :scs (any-reg) :load-if (or (not (location= x r)) - (not (typep y '(signed-byte 29)))))) + (not (typep y 'short-tagged-num))))) (:result-types tagged-num) (:note "inline fixnum arithmetic")) @@ -157,7 +163,7 @@ (:translate ,translate) (:generator 1 (move r x) - (inst ,op r (if (typep y '(signed-byte 29)) + (inst ,op r (if (typep y 'short-tagged-num) (fixnumize y) (register-inline-constant :qword (fixnumize y)))))) (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED") @@ -228,20 +234,20 @@ (define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op) (:translate +) (:args (x :target r :scs (any-reg) - :load-if (or (not (typep y '(signed-byte 29))) + :load-if (or (not (typep y 'short-tagged-num)) (not (sc-is x any-reg control-stack))))) (:info y) (:arg-types tagged-num (:constant fixnum)) (:results (r :scs (any-reg) :load-if (or (not (location= x r)) - (not (typep y '(signed-byte 29)))))) + (not (typep y 'short-tagged-num))))) (:result-types tagged-num) (:note "inline fixnum arithmetic") (:generator 1 (cond ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r)) - (typep y '(signed-byte 29))) + (typep y 'short-tagged-num)) (inst lea r (make-ea :qword :base x :disp (fixnumize y)))) - ((typep y '(signed-byte 29)) + ((typep y 'short-tagged-num) (move r x) (inst add r (fixnumize y))) (t @@ -535,7 +541,7 @@ (:generator 30 (move eax x) (inst cqo) - (if (typep y '(signed-byte 29)) + (if (typep y 'short-tagged-num) (inst mov y-arg (fixnumize y)) (setf y-arg (register-inline-constant :qword (fixnumize y)))) (inst idiv eax y-arg) @@ -1114,7 +1120,7 @@ constant shift greater than word length"))) (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) (:args (x :scs (any-reg) - :load-if (or (not (typep y '(signed-byte 29))) + :load-if (or (not (typep y 'short-tagged-num)) (not (sc-is x any-reg control-stack))))) (:arg-types tagged-num (:constant fixnum)) (:info y)) @@ -1166,7 +1172,7 @@ constant shift greater than word length"))) (inst cmp x ,(case suffix (-c/fixnum - `(if (typep y '(signed-byte 29)) + `(if (typep y 'short-tagged-num) (fixnumize y) (register-inline-constant :qword (fixnumize y)))) @@ -1249,7 +1255,7 @@ constant shift greater than word length"))) (define-vop (fast-eql-c/fixnum fast-conditional/fixnum) (:args (x :scs (any-reg) - :load-if (or (not (typep y '(signed-byte 29))) + :load-if (or (not (typep y 'short-tagged-num)) (not (sc-is x any-reg descriptor-reg control-stack))))) (:arg-types tagged-num (:constant fixnum)) (:info y) @@ -1257,7 +1263,7 @@ constant shift greater than word length"))) (:generator 2 (cond ((and (sc-is x any-reg descriptor-reg) (zerop y)) (inst test x x)) ; smaller instruction - ((typep y '(signed-byte 29)) + ((typep y 'short-tagged-num) (inst cmp x (fixnumize y))) (t (inst cmp x (register-inline-constant :qword (fixnumize y))))))) diff --git a/tests/arith.pure.lisp b/tests/arith.pure.lisp index 05a36ea..e6543e7 100644 --- a/tests/arith.pure.lisp +++ b/tests/arith.pure.lisp @@ -339,19 +339,27 @@ (test-op (op) (let ((ub `(unsigned-byte ,sb-vm:n-word-bits)) (sb `(signed-byte ,sb-vm:n-word-bits))) - (loop for (x y type) in `((2 1 fixnum) - (2 1 ,ub) - (2 1 ,sb) - (,(1+ (ash 1 28)) ,(1- (ash 1 28)) fixnum) - (,(+ 3 (ash 1 30)) ,(+ 2 (ash 1 30)) ,ub) - (,(- -2 (ash 1 29)) ,(- 3 (ash 1 29)) ,sb) - ,@(when (> sb-vm:n-word-bits 32) - `((,(1+ (ash 1 29)) ,(1- (ash 1 29)) fixnum) - (,(1+ (ash 1 31)) ,(1- (ash 1 31)) ,ub) - (,(- -2 (ash 1 31)) ,(- 3 (ash 1 30)) ,sb) - (,(ash 1 40) ,(ash 1 39) fixnum) - (,(ash 1 40) ,(ash 1 39) ,ub) - (,(ash 1 40) ,(ash 1 39) ,sb)))) + (loop for (x y type) + in `((2 1 fixnum) + (2 1 ,ub) + (2 1 ,sb) + (,(1+ (ash 1 28)) ,(1- (ash 1 28)) fixnum) + (,(+ 3 (ash 1 30)) ,(+ 2 (ash 1 30)) ,ub) + (,(- -2 (ash 1 29)) ,(- 3 (ash 1 29)) ,sb) + ,@(when (> sb-vm:n-word-bits 32) + `((,(1+ (ash 1 29)) ,(1- (ash 1 29)) fixnum) + (,(1+ (ash 1 31)) ,(1- (ash 1 31)) ,ub) + (,(- -2 (ash 1 31)) ,(- 3 (ash 1 30)) ,sb) + (,(ash 1 40) ,(ash 1 39) fixnum) + (,(ash 1 40) ,(ash 1 39) ,ub) + (,(ash 1 40) ,(ash 1 39) ,sb))) + ;; fixnums that can be represented as 32-bit + ;; sign-extended immediates on x86-64 + ,@(when (and (> sb-vm:n-word-bits 32) + (< sb-vm:n-fixnum-tag-bits 3)) + `((,(1+ (ash 1 (- 31 sb-vm:n-fixnum-tag-bits))) + ,(1- (ash 1 (- 32 sb-vm:n-fixnum-tag-bits))) + fixnum)))) do (test-case op x y type) (test-case op x x type))))) -- 1.7.10.4