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.

diff --git a/src/compiler/x86-64/arith.lisp b/src/compiler/x86-64/arith.lisp
index b8ee90c..9d48e29 100644 (file)
--- a/src/compiler/x86-64/arith.lisp
+++ b/src/compiler/x86-64/arith.lisp
@@ -11,6 +11,12 @@
 
 (in-package "SB!VM")
 \f
+
+;; 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 (file)
--- 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)))))