Change x86oid modular arithmetic to work if fixnum width changes.

  * This is largely (signed-byte {30,61}) => fixnum and smod{30,61} =>
modfx.

  * Thanks to Paul Khuong for the initial patch.

diff --git a/src/code/cross-modular.lisp b/src/code/cross-modular.lisp
index 931a90f..3f8d1d1 100644 (file)
--- a/src/code/cross-modular.lisp
+++ b/src/code/cross-modular.lisp
@@ -45,16 +45,13 @@
       (do-mfuns *tagged-modular-class*)))
   `(progn ,@(forms)))
 
-#!+#.(cl:if (cl:= sb!vm:n-machine-word-bits 32) '(and) '(or))
-(defun sb!vm::ash-left-mod32 (integer amount)
-  (ldb (byte 32 0) (ash integer amount)))
-#!+#.(cl:if (cl:= sb!vm:n-machine-word-bits 64) '(and) '(or))
-(defun sb!vm::ash-left-mod64 (integer amount)
-  (ldb (byte 64 0) (ash integer amount)))
-#!+x86
-(defun sb!vm::ash-left-smod30 (integer amount)
-  (mask-signed-field 30 (ash integer amount)))
-#!+x86-64
-(defun sb!vm::ash-left-smod61 (integer amount)
-  (mask-signed-field 61 (ash integer amount)))
+#.`
+(defun ,(intern (format nil "ASH-LEFT-MOD~D" sb!vm:n-machine-word-bits)
+                "SB!VM")
+    (integer amount)
+  (ldb (byte ,sb!vm:n-machine-word-bits 0) (ash integer amount)))
 
+#!+(or x86 x86-64)
+(defun sb!vm::ash-left-modfx (integer amount)
+  (mask-signed-field (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)
+                     (ash integer amount)))

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index fe6f9d1..b6ba6a2 100644 (file)
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -1496,14 +1496,9 @@ the first."
     (bignum (ldb (byte 64 0)
                  (ash (logand integer #xffffffffffffffff) amount)))))
 
-#!+x86
-(defun sb!vm::ash-left-smod30 (integer amount)
-  (etypecase integer
-    ((signed-byte 30) (sb!c::mask-signed-field 30 (ash integer amount)))
-    (integer (sb!c::mask-signed-field 30 (ash (sb!c::mask-signed-field 30 integer) amount)))))
-
-#!+x86-64
-(defun sb!vm::ash-left-smod61 (integer amount)
-  (etypecase integer
-    ((signed-byte 61) (sb!c::mask-signed-field 61 (ash integer amount)))
-    (integer (sb!c::mask-signed-field 61 (ash (sb!c::mask-signed-field 61 integer) amount)))))
+#!+(or x86 x86-64)
+(defun sb!vm::ash-left-modfx (integer amount)
+  (let ((fixnum-width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)))
+    (etypecase integer
+      (fixnum (sb!c::mask-signed-field fixnum-width (ash integer amount)))
+      (integer (sb!c::mask-signed-field fixnum-width (ash (sb!c::mask-signed-field fixnum-width integer) amount))))))

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 287162b..1196ba2 100644 (file)
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -624,14 +624,13 @@
   ;; This should really be dependent on SB!VM:N-WORD-BITS, but since we
   ;; don't have a true Alpha64 port yet, we'll have to stick to
   ;; SB!VM:N-MACHINE-WORD-BITS for the time being.  --njf, 2004-08-14
-  #!+#.(cl:if (cl:= 32 sb!vm:n-machine-word-bits) '(and) '(or))
-  (progn
-    #!+x86 (def sb!vm::ash-left-smod30 :tagged 30 t)
-    (def sb!vm::ash-left-mod32 :untagged 32 nil))
-  #!+#.(cl:if (cl:= 64 sb!vm:n-machine-word-bits) '(and) '(or))
-  (progn
-    #!+x86-64 (def sb!vm::ash-left-smod61 :tagged 61 t)
-    (def sb!vm::ash-left-mod64 :untagged 64 nil)))
+  #.`(progn
+       #!+(or x86 x86-64)
+       (def sb!vm::ash-left-modfx
+           :tagged ,(- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits) t)
+       (def ,(intern (format nil "ASH-LEFT-MOD~D" sb!vm:n-machine-word-bits)
+                     "SB!VM")
+           :untagged ,sb!vm:n-machine-word-bits nil)))
 \f
 ;;;; word-wise logical operations
 

diff --git a/src/compiler/x86-64/arith.lisp b/src/compiler/x86-64/arith.lisp
index cd06c8e..3c6420f 100644 (file)
--- a/src/compiler/x86-64/arith.lisp
+++ b/src/compiler/x86-64/arith.lisp
@@ -679,7 +679,7 @@
           (t
            (move result number)
            (cond ((< -64 amount 64)
-                  ;; this code is used both in ASH and ASH-SMOD61, so
+                  ;; this code is used both in ASH and ASH-MODFX, so
                   ;; be careful
                   (if (plusp amount)
                       (inst shl result amount)
@@ -1343,18 +1343,19 @@ constant shift greater than word length")))
                    (vop64f (intern (format nil "FAST-~S-MOD64/FIXNUM=>FIXNUM" name)))
                    (vop64cu (intern (format nil "FAST-~S-MOD64-C/WORD=>UNSIGNED" name)))
                    (vop64cf (intern (format nil "FAST-~S-MOD64-C/FIXNUM=>FIXNUM" name)))
-                   (sfun61 (intern (format nil "~S-SMOD61" name)))
-                   (svop61f (intern (format nil "FAST-~S-SMOD61/FIXNUM=>FIXNUM" name)))
-                   (svop61cf (intern (format nil "FAST-~S-SMOD61-C/FIXNUM=>FIXNUM" name))))
+                   (funfx (intern (format nil "~S-MODFX" name)))
+                   (vopfxf (intern (format nil "FAST-~S-MODFX/FIXNUM=>FIXNUM" name)))
+                   (vopfxcf (intern (format nil "FAST-~S-MODFX-C/FIXNUM=>FIXNUM" name))))
                `(progn
                   (define-modular-fun ,fun64 (x y) ,name :untagged nil 64)
-                  (define-modular-fun ,sfun61 (x y) ,name :tagged t 61)
+                  (define-modular-fun ,funfx (x y) ,name :tagged t
+                                      #.(- n-word-bits n-fixnum-tag-bits))
                   (define-mod-binop (,vop64u ,vopu) ,fun64)
                   (define-vop (,vop64f ,vopf) (:translate ,fun64))
-                  (define-vop (,svop61f ,vopf) (:translate ,sfun61))
+                  (define-vop (,vopfxf ,vopf) (:translate ,funfx))
                   ,@(when -c-p
                       `((define-mod-binop-c (,vop64cu ,vopcu) ,fun64)
-                        (define-vop (,svop61cf ,vopcf) (:translate ,sfun61))))))))
+                        (define-vop (,vopfxcf ,vopcf) (:translate ,funfx))))))))
   (def + t)
   (def - t)
   (def * t))
@@ -1370,25 +1371,25 @@ constant shift greater than word length")))
     (sb!c::give-up-ir1-transform))
   '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
 
-(define-vop (fast-ash-left-smod61-c/fixnum=>fixnum
+(define-vop (fast-ash-left-modfx-c/fixnum=>fixnum
              fast-ash-c/fixnum=>fixnum)
   (:variant :modular)
-  (:translate ash-left-smod61))
-(define-vop (fast-ash-left-smod61/fixnum=>fixnum
+  (:translate ash-left-modfx))
+(define-vop (fast-ash-left-modfx/fixnum=>fixnum
              fast-ash-left/fixnum=>fixnum))
-(deftransform ash-left-smod61 ((integer count)
-                               ((signed-byte 61) (unsigned-byte 6)))
+(deftransform ash-left-modfx ((integer count)
+                              (fixnum (unsigned-byte 6)))
   (when (sb!c::constant-lvar-p count)
     (sb!c::give-up-ir1-transform))
-  '(%primitive fast-ash-left-smod61/fixnum=>fixnum integer count))
+  '(%primitive fast-ash-left-modfx/fixnum=>fixnum integer count))
 
 (in-package "SB!C")
 
 (defknown sb!vm::%lea-mod64 (integer integer (member 1 2 4 8) (signed-byte 64))
   (unsigned-byte 64)
   (foldable flushable movable))
-(defknown sb!vm::%lea-smod61 (integer integer (member 1 2 4 8) (signed-byte 64))
-  (signed-byte 61)
+(defknown sb!vm::%lea-modfx (integer integer (member 1 2 4 8) (signed-byte 64))
+  fixnum
   (foldable flushable movable))
 
 (define-modular-fun-optimizer %lea ((base index scale disp) :untagged nil :width width)
@@ -1399,19 +1400,20 @@ constant shift greater than word length")))
     (cut-to-width index :untagged width nil)
     'sb!vm::%lea-mod64))
 (define-modular-fun-optimizer %lea ((base index scale disp) :tagged t :width width)
-  (when (and (<= width 61)
+  (when (and (<= width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
              (constant-lvar-p scale)
              (constant-lvar-p disp))
     (cut-to-width base :tagged width t)
     (cut-to-width index :tagged width t)
-    'sb!vm::%lea-smod61))
+    'sb!vm::%lea-modfx))
 
 #+sb-xc-host
 (progn
   (defun sb!vm::%lea-mod64 (base index scale disp)
     (ldb (byte 64 0) (%lea base index scale disp)))
-  (defun sb!vm::%lea-smod61 (base index scale disp)
-    (mask-signed-field 61 (%lea base index scale disp))))
+  (defun sb!vm::%lea-modfx (base index scale disp)
+    (mask-signed-field (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)
+                       (%lea base index scale disp))))
 #-sb-xc-host
 (progn
   (defun sb!vm::%lea-mod64 (base index scale disp)
@@ -1420,21 +1422,22 @@ constant shift greater than word length")))
       ;; can't use modular version of %LEA, as we only have VOPs for
       ;; constant SCALE and DISP.
       (ldb (byte 64 0) (+ base (* index scale) disp))))
-  (defun sb!vm::%lea-smod61 (base index scale disp)
-    (let ((base (mask-signed-field 61 base))
-          (index (mask-signed-field 61 index)))
+  (defun sb!vm::%lea-modfx (base index scale disp)
+    (let* ((fixnum-width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
+           (base (mask-signed-field fixnum-width base))
+           (index (mask-signed-field fixnum-width index)))
       ;; can't use modular version of %LEA, as we only have VOPs for
       ;; constant SCALE and DISP.
-      (mask-signed-field 61 (+ base (* index scale) disp)))))
+      (mask-signed-field fixnum-width (+ base (* index scale) disp)))))
 
 (in-package "SB!VM")
 
 (define-vop (%lea-mod64/unsigned=>unsigned
              %lea/unsigned=>unsigned)
   (:translate %lea-mod64))
-(define-vop (%lea-smod61/fixnum=>fixnum
+(define-vop (%lea-modfx/fixnum=>fixnum
              %lea/fixnum=>fixnum)
-  (:translate %lea-smod61))
+  (:translate %lea-modfx))
 
 ;;; logical operations
 (define-modular-fun lognot-mod64 (x) lognot :untagged nil 64)
@@ -1786,14 +1789,14 @@ constant shift greater than word length")))
     (*-transformer y)))
 
 (deftransform * ((x y)
-                 ((signed-byte 61) (constant-arg (unsigned-byte 64)))
-                 (signed-byte 61))
+                 (fixnum (constant-arg (unsigned-byte 64)))
+                 fixnum)
   "recode as leas, shifts and adds"
   (let ((y (lvar-value y)))
     (*-transformer y)))
-(deftransform sb!vm::*-smod61
-    ((x y) ((signed-byte 61) (constant-arg (unsigned-byte 64)))
-     (signed-byte 61))
+(deftransform sb!vm::*-modfx
+    ((x y) (fixnum (constant-arg (unsigned-byte 64)))
+     fixnum)
   "recode as leas, shifts and adds"
   (let ((y (lvar-value y)))
     (*-transformer y)))

diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp
index 6965fee..b451680 100644 (file)
--- a/src/compiler/x86/arith.lisp
+++ b/src/compiler/x86/arith.lisp
@@ -609,7 +609,7 @@
           (t
            (move result number)
            (cond ((< -32 amount 32)
-                  ;; this code is used both in ASH and ASH-SMOD30, so
+                  ;; this code is used both in ASH and ASH-MODFX, so
                   ;; be careful
                   (if (plusp amount)
                       (inst shl result amount)
@@ -1298,18 +1298,19 @@ constant shift greater than word length")))
                    (vop32f (intern (format nil "FAST-~S-MOD32/FIXNUM=>FIXNUM" name)))
                    (vop32cu (intern (format nil "FAST-~S-MOD32-C/WORD=>UNSIGNED" name)))
                    (vop32cf (intern (format nil "FAST-~S-MOD32-C/FIXNUM=>FIXNUM" name)))
-                   (sfun30 (intern (format nil "~S-SMOD30" name)))
-                   (svop30f (intern (format nil "FAST-~S-SMOD30/FIXNUM=>FIXNUM" name)))
-                   (svop30cf (intern (format nil "FAST-~S-SMOD30-C/FIXNUM=>FIXNUM" name))))
+                   (funfx (intern (format nil "~S-MODFX" name)))
+                   (vopfxf (intern (format nil "FAST-~S-MODFX/FIXNUM=>FIXNUM" name)))
+                   (vopfxcf (intern (format nil "FAST-~S-MODFX-C/FIXNUM=>FIXNUM" name))))
                `(progn
                   (define-modular-fun ,fun32 (x y) ,name :untagged nil 32)
-                  (define-modular-fun ,sfun30 (x y) ,name :tagged t 30)
+                  (define-modular-fun ,funfx (x y) ,name :tagged t
+                                      #.(- n-word-bits n-fixnum-tag-bits))
                   (define-mod-binop (,vop32u ,vopu) ,fun32)
                   (define-vop (,vop32f ,vopf) (:translate ,fun32))
-                  (define-vop (,svop30f ,vopf) (:translate ,sfun30))
+                  (define-vop (,vopfxf ,vopf) (:translate ,funfx))
                   ,@(when -c-p
                       `((define-mod-binop-c (,vop32cu ,vopcu) ,fun32)
-                        (define-vop (,svop30cf ,vopcf) (:translate ,sfun30))))))))
+                        (define-vop (,vopfxcf ,vopcf) (:translate ,funfx))))))))
   (def + t)
   (def - t)
   ;; (no -C variant as x86 MUL instruction doesn't take an immediate)
@@ -1328,26 +1329,26 @@ constant shift greater than word length")))
     (sb!c::give-up-ir1-transform))
   '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
 
-(define-vop (fast-ash-left-smod30-c/fixnum=>fixnum
+(define-vop (fast-ash-left-modfx-c/fixnum=>fixnum
              fast-ash-c/fixnum=>fixnum)
   (:variant :modular)
-  (:translate ash-left-smod30))
+  (:translate ash-left-modfx))
 
-(define-vop (fast-ash-left-smod30/fixnum=>fixnum
+(define-vop (fast-ash-left-modfx/fixnum=>fixnum
              fast-ash-left/fixnum=>fixnum))
-(deftransform ash-left-smod30 ((integer count)
-                               ((signed-byte 30) (unsigned-byte 5)))
+(deftransform ash-left-modfx ((integer count)
+                              (fixnum (unsigned-byte 5)))
   (when (sb!c::constant-lvar-p count)
     (sb!c::give-up-ir1-transform))
-  '(%primitive fast-ash-left-smod30/fixnum=>fixnum integer count))
+  '(%primitive fast-ash-left-modfx/fixnum=>fixnum integer count))
 
 (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))
-(defknown sb!vm::%lea-smod30 (integer integer (member 1 2 4 8) (signed-byte 32))
-  (signed-byte 30)
+(defknown sb!vm::%lea-modfx (integer integer (member 1 2 4 8) (signed-byte 32))
+  fixnum
   (foldable flushable movable))
 
 (define-modular-fun-optimizer %lea ((base index scale disp) :untagged nil :width width)
@@ -1358,19 +1359,20 @@ constant shift greater than word length")))
     (cut-to-width index :untagged width nil)
     'sb!vm::%lea-mod32))
 (define-modular-fun-optimizer %lea ((base index scale disp) :tagged t :width width)
-  (when (and (<= width 30)
+  (when (and (<= width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
              (constant-lvar-p scale)
              (constant-lvar-p disp))
     (cut-to-width base :tagged width t)
     (cut-to-width index :tagged width t)
-    'sb!vm::%lea-smod30))
+    'sb!vm::%lea-modfx))
 
 #+sb-xc-host
 (progn
   (defun sb!vm::%lea-mod32 (base index scale disp)
     (ldb (byte 32 0) (%lea base index scale disp)))
-  (defun sb!vm::%lea-smod30 (base index scale disp)
-    (mask-signed-field 30 (%lea base index scale disp))))
+  (defun sb!vm::%lea-modfx (base index scale disp)
+    (mask-signed-field (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)
+                       (%lea base index scale disp))))
 #-sb-xc-host
 (progn
   (defun sb!vm::%lea-mod32 (base index scale disp)
@@ -1379,21 +1381,22 @@ constant shift greater than word length")))
       ;; can't use modular version of %LEA, as we only have VOPs for
       ;; constant SCALE and DISP.
       (ldb (byte 32 0) (+ base (* index scale) disp))))
-  (defun sb!vm::%lea-smod30 (base index scale disp)
-    (let ((base (mask-signed-field 30 base))
-          (index (mask-signed-field 30 index)))
+  (defun sb!vm::%lea-modfx (base index scale disp)
+    (let* ((fixnum-width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
+           (base (mask-signed-field fixnum-width base))
+           (index (mask-signed-field fixnum-width index)))
       ;; can't use modular version of %LEA, as we only have VOPs for
       ;; constant SCALE and DISP.
-      (mask-signed-field 30 (+ base (* index scale) disp)))))
+      (mask-signed-field fixnum-width (+ base (* index scale) disp)))))
 
 (in-package "SB!VM")
 
 (define-vop (%lea-mod32/unsigned=>unsigned
              %lea/unsigned=>unsigned)
   (:translate %lea-mod32))
-(define-vop (%lea-smod30/fixnum=>fixnum
+(define-vop (%lea-modfx/fixnum=>fixnum
              %lea/fixnum=>fixnum)
-  (:translate %lea-smod30))
+  (:translate %lea-modfx))
 
 ;;; logical operations
 (define-modular-fun lognot-mod32 (x) lognot :untagged nil 32)
@@ -1886,17 +1889,17 @@ constant shift greater than word length")))
     (*-transformer :unsigned 32 y)))
 
 (deftransform * ((x y)
-                 ((signed-byte 30) (constant-arg (unsigned-byte 32)))
-                 (signed-byte 30))
+                 (fixnum (constant-arg (unsigned-byte 32)))
+                 fixnum)
   "recode as leas, shifts and adds"
   (let ((y (lvar-value y)))
-    (*-transformer :signed 30 y)))
-(deftransform sb!vm::*-smod30
-    ((x y) ((signed-byte 30) (constant-arg (unsigned-byte 32)))
-     (signed-byte 30))
+    (*-transformer :signed (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits) y)))
+(deftransform sb!vm::*-modfx
+    ((x y) (fixnum (constant-arg (unsigned-byte 32)))
+     fixnum)
   "recode as leas, shifts and adds"
   (let ((y (lvar-value y)))
-    (*-transformer :signed 30 y)))
+    (*-transformer :signed (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits) y)))
 
 ;;; FIXME: we should also be able to write an optimizer or two to
 ;;; convert (+ (* x 2) 17), (- (* x 9) 5) to a %LEA.