From e9984509712529c60d1158d44207d6abf11dccce Mon Sep 17 00:00:00 2001 From: Alastair Bridgewater Date: Sun, 27 Dec 2009 11:53:45 -0500 Subject: [PATCH] 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. --- src/code/cross-modular.lisp | 21 +++++------- src/code/numbers.lisp | 17 ++++------ src/compiler/generic/vm-tran.lisp | 15 ++++----- src/compiler/x86-64/arith.lisp | 63 +++++++++++++++++----------------- src/compiler/x86/arith.lisp | 67 +++++++++++++++++++------------------ 5 files changed, 90 insertions(+), 93 deletions(-) diff --git a/src/code/cross-modular.lisp b/src/code/cross-modular.lisp index 931a90f..3f8d1d1 100644 --- 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 --- 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 --- 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))) ;;;; word-wise logical operations diff --git a/src/compiler/x86-64/arith.lisp b/src/compiler/x86-64/arith.lisp index cd06c8e..3c6420f 100644 --- 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 --- 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. -- 1.7.10.4