From: Nathan Froyd <froydnj@cs.rice.edu>
Date: Wed, 8 Dec 2004 16:31:41 +0000 (+0000)
Subject: 0.8.17.24:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=6a7ffd51f991961a59c4496bd80aaa89698231f9;p=sbcl.git

0.8.17.24:
	Reinstate fixnum arithmetic when possible by defining modular
	  arithmetic mechanisms for (UNSIGNED-BYTE 29)
	... this feels like a big, ugly hack, since the compiler is
	      (presumably) smart enough to do this when modular
	      arithmetic was not present;
	... move some EVAL-WHEN macros into a MACROLET while we're at it;
	... builds and passes tests on x86/Linux; will probably build
	      properly on other platforms, but will fail tests in
	      (at least) tests/arith.pure.  These test failures seem
	      harmless enough and will be fixed in another revision or
	      two.
---

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index 330fcdd..0d6d868 100644
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -1420,11 +1420,17 @@ the first."
 ;;; shifts.  See also the comment in (LOGAND OPTIMIZER) for more
 ;;; discussion of this hack.  -- CSR, 2003-10-09
 #!-alpha
+(progn
 (defun sb!vm::ash-left-mod32 (integer amount)
   (etypecase integer
     ((unsigned-byte 32) (ldb (byte 32 0) (ash integer amount)))
     (fixnum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount)))
     (bignum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount)))))
+(defun sb!vm::ash-left-mod29 (integer amount)
+  (etypecase integer
+    (fixnum (ldb (byte 29 0) (ash (logand integer #x1fffffff) amount)))
+    (bignum (ldb (byte 29 0) (ash (logand integer #x1fffffff) amount)))))
+) ; PROGN
 #!+alpha
 (defun sb!vm::ash-left-mod64 (integer amount)
   (etypecase integer
diff --git a/src/compiler/alpha/arith.lisp b/src/compiler/alpha/arith.lisp
index e8c0586..971f228 100644
--- a/src/compiler/alpha/arith.lisp
+++ b/src/compiler/alpha/arith.lisp
@@ -411,20 +411,26 @@
     (sb!c::give-up-ir1-transform))
   '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
 
-(macrolet
-    ((define-modular-backend (fun &optional constantp)
-       (let ((mfun-name (symbolicate fun '-mod64))
-             (modvop (symbolicate 'fast- fun '-mod64/unsigned=>unsigned))
-             (modcvop (symbolicate 'fast- fun '-mod64-c/unsigned=>unsigned))
-             (vop (symbolicate 'fast- fun '/unsigned=>unsigned))
-             (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
-         `(progn
-            (define-modular-fun ,mfun-name (x y) ,fun 64)
-            (define-vop (,modvop ,vop)
-              (:translate ,mfun-name))
-            ,@(when constantp
-                `((define-vop (,modcvop ,cvop)
-                    (:translate ,mfun-name))))))))
+(macrolet ((define-modular-backend (fun &optional constantp)
+             (collect ((forms))
+               (dolist (info '((29 fixnum) (32 unsigned)))
+                 (destructuring-bind (width regtype) info
+                   (let ((mfun-name (intern (format nil "~A-MOD~A" fun width)))
+                         (mvop (intern (format nil "FAST-~A-MOD~A/~A=>~A"
+                                               fun width regtype regtype)))
+                         (mcvop (intern (format nil "FAST-~A-MOD~A-C/~A=>~A"
+                                                fun width regtype regtype)))
+                         (vop (intern (format nil "FAST-~A/~A=>~A"
+                                              fun regtype regtype)))
+                         (cvop (intern (format nil "FAST-~A-C/~A=>~A"
+                                               fun regtype regtype))))
+                     (forms `(define-modular-fun ,mfun-name (x y) ,fun ,width))
+                     (forms `(define-vop (,mvop ,vop)
+                              (:translate ,mfun-name)))
+                     (when constantp
+                       (forms `(define-vop (,mcvop ,cvop)
+                                (:translate ,mfun-name)))))))
+               `(progn ,@(forms)))))
   (define-modular-backend + t)
   (define-modular-backend - t)
   (define-modular-backend logxor t)
diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index e47aec5..87efca8 100644
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -510,6 +510,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
+  ;;
+  ;; FIXME: I think we only want a single optimizer for ASH; this code
+  ;; currently defines two (the second one, AFAICS, overrides the first),
+  ;; but everything "works"--ASH with results of 29 bits or fewer use
+  ;; fixnum arithmetic.  -- njf, 2004-12-08
+  #!+#.(cl:if (cl:= 32 sb!vm:n-machine-word-bits) '(and) '(or))
+  (def sb!vm::ash-left-mod29 29)
   #!+#.(cl:if (cl:= 32 sb!vm:n-machine-word-bits) '(and) '(or))
   (def sb!vm::ash-left-mod32 32)
   #!+#.(cl:if (cl:= 64 sb!vm:n-machine-word-bits) '(and) '(or))
diff --git a/src/compiler/hppa/arith.lisp b/src/compiler/hppa/arith.lisp
index 78b3f53..cc1f8c4 100644
--- a/src/compiler/hppa/arith.lisp
+++ b/src/compiler/hppa/arith.lisp
@@ -580,16 +580,34 @@
   
 
 ;;;; modular functions
-(define-modular-fun +-mod32 (x y) + 32)
-(define-vop (fast-+-mod32/unsigned=>unsigned fast-+/unsigned=>unsigned)
-  (:translate +-mod32))
-(define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned)
-  (:translate +-mod32))
-(define-modular-fun --mod32 (x y) - 32)
-(define-vop (fast---mod32/unsigned=>unsigned fast--/unsigned=>unsigned)
-  (:translate --mod32))
-(define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
-  (:translate --mod32))
+
+(macrolet ((define-modular-backend (fun &optional constantp)
+             (collect ((forms))
+               (dolist (info '((29 fixnum) (32 unsigned)))
+                 (destructuring-bind (width regtype) info
+                   (let ((mfun-name (intern (format nil "~A-MOD~A" fun width)))
+                         (mvop (intern (format nil "FAST-~A-MOD~A/~A=>~A"
+                                               fun width regtype regtype)))
+                         (mcvop (intern (format nil "FAST-~A-MOD~A-C/~A=>~A"
+                                                fun width regtype regtype)))
+                         (vop (intern (format nil "FAST-~A/~A=>~A"
+                                              fun regtype regtype)))
+                         (cvop (intern (format nil "FAST-~A-C/~A=>~A"
+                                               fun regtype regtype))))
+                     (forms `(define-modular-fun ,mfun-name (x y) ,fun ,width))
+                     (forms `(define-vop (,mvop ,vop)
+                              (:translate ,mfun-name)))
+                     (when constantp
+                       (forms `(define-vop (,mcvop ,cvop)
+                                (:translate ,mfun-name)))))))
+               `(progn ,@(forms)))))
+  (define-modular-backend + t)
+  (define-modular-backend - t)
+  ;; FIXME: constant versions of these could be defined if anybody
+  ;; cared enough to implement them. -- CSR/NJF
+  (define-modular-backend logxor)
+  (define-modular-backend logandc1)
+  (define-modular-backend logandc2))
 
 (define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
 	     fast-ash-c/unsigned=>unsigned)
@@ -615,21 +633,6 @@
   (:generator 1
     (inst uaddcm zero-tn x res)))
 
-(macrolet
-    ((define-modular-backend (fun)
-       (let ((mfun-name (symbolicate fun '-mod32))
-	     ;; FIXME: if anyone cares, add constant-arg vops.  --
-	     ;; CSR, 2003-09-16
-	     (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
-	     (vop (symbolicate 'fast- fun '/unsigned=>unsigned)))
-	 `(progn
-	    (define-modular-fun ,mfun-name (x y) ,fun 32)
-	    (define-vop (,modvop ,vop)
-	      (:translate ,mfun-name))))))
-  (define-modular-backend logxor)
-  (define-modular-backend logandc1)
-  (define-modular-backend logandc2))
-
 (define-source-transform logeqv (&rest args)
   (if (oddp (length args))
       `(logxor ,@args)
diff --git a/src/compiler/mips/arith.lisp b/src/compiler/mips/arith.lisp
index 9ae3a64..6d73c2b 100644
--- a/src/compiler/mips/arith.lisp
+++ b/src/compiler/mips/arith.lisp
@@ -667,16 +667,30 @@
        (inst sll r num amount)))))
 
 ;;;; Modular arithmetic
-(define-modular-fun +-mod32 (x y) + 32)
-(define-vop (fast-+-mod32/unsigned=>unsigned fast-+/unsigned=>unsigned)
-  (:translate +-mod32))
-(define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned)
-  (:translate +-mod32))
-(define-modular-fun --mod32 (x y) - 32)
-(define-vop (fast---mod32/unsigned=>unsigned fast--/unsigned=>unsigned)
-  (:translate --mod32))
-(define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
-  (:translate --mod32))
+
+(macrolet ((define-modular-backend (fun &optional constantp)
+             (collect ((forms))
+               (dolist (info '((29 fixnum) (32 unsigned)))
+                 (destructuring-bind (width regtype) info
+                   (let ((mfun-name (intern (format nil "~A-MOD~A" fun width)))
+                         (mvop (intern (format nil "FAST-~A-MOD~A/~A=>~A"
+                                               fun width regtype regtype)))
+                         (mcvop (intern (format nil "FAST-~A-MOD~A-C/~A=>~A"
+                                                fun width regtype regtype)))
+                         (vop (intern (format nil "FAST-~A/~A=>~A"
+                                              fun regtype regtype)))
+                         (cvop (intern (format nil "FAST-~A-C/~A=>~A"
+                                               fun regtype regtype))))
+                     (forms `(define-modular-fun ,mfun-name (x y) ,fun ,width))
+                     (forms `(define-vop (,mvop ,vop)
+                              (:translate ,mfun-name)))
+                     (when constantp
+                       (forms `(define-vop (,mcvop ,cvop)
+                                (:translate ,mfun-name)))))))
+               `(progn ,@(forms)))))
+  (define-modular-backend + t)
+  (define-modular-backend - t)
+  (define-modular-backend logxor t))
 
 (define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
 	     fast-ash-c/unsigned=>unsigned)
@@ -702,14 +716,6 @@
   (:generator 1
     (inst nor r x zero-tn)))
 
-(define-modular-fun logxor-mod32 (x y) logxor 32)
-(define-vop (fast-logxor-mod32/unsigned=>unsigned
-             fast-logxor/unsigned=>unsigned)
-  (:translate logxor-mod32))
-(define-vop (fast-logxor-mod32-c/unsigned=>unsigned
-             fast-logxor-c/unsigned=>unsigned)
-  (:translate logxor-mod32))
-
 (define-modular-fun lognor-mod32 (x y) lognor 32)
 (define-vop (fast-lognor-mod32/unsigned=>unsigned
 	     fast-lognor/unsigned=>unsigned)
diff --git a/src/compiler/ppc/arith.lisp b/src/compiler/ppc/arith.lisp
index 369b0e8..8cb995c 100644
--- a/src/compiler/ppc/arith.lisp
+++ b/src/compiler/ppc/arith.lisp
@@ -135,99 +135,90 @@
   (:note "inline (signed-byte 32) arithmetic"))
 
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
-(defmacro define-var-binop (translate untagged-penalty op 
-			    &optional arg-swap restore-fixnum-mask)
-  `(progn
-     (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
-		  fast-fixnum-binop)
-       ,@(when restore-fixnum-mask
-	   `((:temporary (:sc non-descriptor-reg) temp)))
-       (:translate ,translate)
-       (:generator 2
-	 ,(if arg-swap
-	     `(inst ,op ,(if restore-fixnum-mask 'temp 'r) y x)
-	     `(inst ,op ,(if restore-fixnum-mask 'temp 'r) x y))
-	 ;; FIXME: remind me what convention we used for 64bitizing
-	 ;; stuff?  -- CSR, 2003-08-27
-	 ,@(when restore-fixnum-mask
-	     `((inst clrrwi r temp (1- n-lowtag-bits))))))
-     (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
-		  fast-signed-binop)
-       (:translate ,translate)
-       (:generator ,(1+ untagged-penalty)
-         ,(if arg-swap
-	     `(inst ,op r y x)
-	     `(inst ,op r x y))))
-     (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
-		  fast-unsigned-binop)
-       (:translate ,translate)
-       (:generator ,(1+ untagged-penalty)
-	 ,(if arg-swap
-	     `(inst ,op r y x)
-	     `(inst ,op r x y))))))
-
-
-(defmacro define-const-binop (translate untagged-penalty op)
-  `(progn
+(macrolet ((define-var-binop (translate untagged-penalty op 
+                                        &optional arg-swap restore-fixnum-mask)
+               `(progn
+                 (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
+                              fast-fixnum-binop)
+                     ,@(when restore-fixnum-mask
+                             `((:temporary (:sc non-descriptor-reg) temp)))
+                     (:translate ,translate)
+                     (:generator 2
+                      ,(if arg-swap
+                           `(inst ,op ,(if restore-fixnum-mask 'temp 'r) y x)
+                           `(inst ,op ,(if restore-fixnum-mask 'temp 'r) x y))
+                      ;; FIXME: remind me what convention we used for 64bitizing
+                      ;; stuff?  -- CSR, 2003-08-27
+                      ,@(when restore-fixnum-mask
+                              `((inst clrrwi r temp (1- n-lowtag-bits))))))
+                 (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
+                              fast-signed-binop)
+                     (:translate ,translate)
+                   (:generator ,(1+ untagged-penalty)
+                    ,(if arg-swap
+                         `(inst ,op r y x)
+                         `(inst ,op r x y))))
+                 (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
+                              fast-unsigned-binop)
+                     (:translate ,translate)
+                   (:generator ,(1+ untagged-penalty)
+                    ,(if arg-swap
+                         `(inst ,op r y x)
+                         `(inst ,op r x y))))))
+           (define-const-binop (translate untagged-penalty op)
+               `(progn
      
-     (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
-		  fast-fixnum-binop-c)
-       (:translate ,translate)
-       (:generator 1
-	 (inst ,op r x (fixnumize y))))
-     (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
-		  fast-signed-binop-c)
-       (:translate ,translate)
-       (:generator ,untagged-penalty
-	 (inst ,op r x y)))
-     (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
-		  fast-unsigned-binop-c)
-       (:translate ,translate)
-       (:generator ,untagged-penalty
-	 (inst ,op r x y)))))
-
-(defmacro define-const-logop (translate untagged-penalty op)
-  `(progn
+                 (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
+                              fast-fixnum-binop-c)
+                     (:translate ,translate)
+                   (:generator 1
+                    (inst ,op r x (fixnumize y))))
+                 (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
+                              fast-signed-binop-c)
+                     (:translate ,translate)
+                   (:generator ,untagged-penalty
+                    (inst ,op r x y)))
+                 (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
+                              fast-unsigned-binop-c)
+                     (:translate ,translate)
+                   (:generator ,untagged-penalty
+                    (inst ,op r x y)))))
+           (defmacro define-const-logop (translate untagged-penalty op)
+             `(progn
      
-     (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
-		  fast-fixnum-logop-c)
-       (:translate ,translate)
-       (:generator 1
-	 (inst ,op r x (fixnumize y))))
-     (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
-		  fast-signed-logop-c)
-       (:translate ,translate)
-       (:generator ,untagged-penalty
-	 (inst ,op r x y)))
-     (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
-		  fast-unsigned-logop-c)
-       (:translate ,translate)
-       (:generator ,untagged-penalty
-	 (inst ,op r x y)))))
-
-); eval-when
-
-(define-var-binop + 4 add)
-(define-var-binop - 4 sub)
-(define-var-binop logand 2 and)
-(define-var-binop logandc1 2 andc t)
-(define-var-binop logandc2 2 andc)
-(define-var-binop logior 2 or)
-(define-var-binop logorc1 2 orc t t)
-(define-var-binop logorc2 2 orc nil t)
-(define-var-binop logxor 2 xor)
-(define-var-binop logeqv 2 eqv nil t)
-(define-var-binop lognand 2 nand nil t)
-(define-var-binop lognor 2 nor nil t)
-
-(define-const-binop + 4 addi)
-(define-const-binop - 4 subi)
-(define-const-logop logand 2 andi.)
-(define-const-logop logior 2 ori)
-(define-const-logop logxor 2 xori)
-
+               (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
+                            fast-fixnum-logop-c)
+                   (:translate ,translate)
+                 (:generator 1
+                  (inst ,op r x (fixnumize y))))
+               (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
+                            fast-signed-logop-c)
+                   (:translate ,translate)
+                 (:generator ,untagged-penalty
+                  (inst ,op r x y)))
+               (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
+                            fast-unsigned-logop-c)
+                   (:translate ,translate)
+                 (:generator ,untagged-penalty
+                  (inst ,op r x y))))))
+  (define-var-binop + 4 add)
+  (define-var-binop - 4 sub)
+  (define-var-binop logand 2 and)
+  (define-var-binop logandc1 2 andc t)
+  (define-var-binop logandc2 2 andc)
+  (define-var-binop logior 2 or)
+  (define-var-binop logorc1 2 orc t t)
+  (define-var-binop logorc2 2 orc nil t)
+  (define-var-binop logxor 2 xor)
+  (define-var-binop logeqv 2 eqv nil t)
+  (define-var-binop lognand 2 nand nil t)
+  (define-var-binop lognor 2 nor nil t)
+
+  (define-const-binop + 4 addi)
+  (define-const-binop - 4 subi)
+  (define-const-logop logand 2 andi.)
+  (define-const-logop logior 2 ori)
+  (define-const-logop logxor 2 xori))
 
 ;;; Special case fixnum + and - that trap on overflow.  Useful when we
 ;;; don't know that the output type is a fixnum.
@@ -483,20 +474,26 @@
     (sb!c::give-up-ir1-transform))
   '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
 
-(macrolet 
-    ((define-modular-backend (fun &optional constantp)
-       (let ((mfun-name (symbolicate fun '-mod32))
-	     (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
-	     (modcvop (symbolicate 'fast- fun 'mod32-c/unsigned=>unsigned))
-	     (vop (symbolicate 'fast- fun '/unsigned=>unsigned))
-	     (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
-	 `(progn
-	    (define-modular-fun ,mfun-name (x y) ,fun 32)
-	    (define-vop (,modvop ,vop)
-	      (:translate ,mfun-name))
-	    ,@(when constantp
-		`((define-vop (,modcvop ,cvop)
-		    (:translate ,mfun-name))))))))
+(macrolet ((define-modular-backend (fun &optional constantp)
+             (collect ((forms))
+               (dolist (info '((29 fixnum) (32 unsigned)))
+                 (destructuring-bind (width regtype) info
+                   (let ((mfun-name (intern (format nil "~A-MOD~A" fun width)))
+                         (mvop (intern (format nil "FAST-~A-MOD~A/~A=>~A"
+                                               fun width regtype regtype)))
+                         (mcvop (intern (format nil "FAST-~A-MOD~A-C/~A=>~A"
+                                                fun width regtype regtype)))
+                         (vop (intern (format nil "FAST-~A/~A=>~A"
+                                              fun regtype regtype)))
+                         (cvop (intern (format nil "FAST-~A-C/~A=>~A"
+                                               fun regtype regtype))))
+                     (forms `(define-modular-fun ,mfun-name (x y) ,fun ,width))
+                     (forms `(define-vop (,mvop ,vop)
+                              (:translate ,mfun-name)))
+                     (when constantp
+                       (forms `(define-vop (,mcvop ,cvop)
+                                (:translate ,mfun-name)))))))
+               `(progn ,@(forms)))))
   (define-modular-backend + t)
   (define-modular-backend - t)
   (define-modular-backend * t)
diff --git a/src/compiler/sparc/arith.lisp b/src/compiler/sparc/arith.lisp
index 1f40039..8e55634 100644
--- a/src/compiler/sparc/arith.lisp
+++ b/src/compiler/sparc/arith.lisp
@@ -658,20 +658,26 @@
   (:generator 1
     (inst not res x)))
 
-(macrolet
-    ((define-modular-backend (fun &optional constantp)
-       (let ((mfun-name (symbolicate fun '-mod32))
-             (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
-             (modcvop (symbolicate 'fast- fun '-mod32-c/unsigned=>unsigned))
-             (vop (symbolicate 'fast- fun '/unsigned=>unsigned))
-             (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
-         `(progn
-            (define-modular-fun ,mfun-name (x y) ,fun 32)
-            (define-vop (,modvop ,vop)
-              (:translate ,mfun-name))
-	    ,@(when constantp
-		`((define-vop (,modcvop ,cvop)
-		    (:translate ,mfun-name))))))))
+(macrolet ((define-modular-backend (fun &optional constantp)
+             (collect ((forms))
+               (dolist (info '((29 fixnum) (32 unsigned)))
+                 (destructuring-bind (width regtype) info
+                   (let ((mfun-name (intern (format nil "~A-MOD~A" fun width)))
+                         (mvop (intern (format nil "FAST-~A-MOD~A/~A=>~A"
+                                               fun width regtype regtype)))
+                         (mcvop (intern (format nil "FAST-~A-MOD~A-C/~A=>~A"
+                                                fun width regtype regtype)))
+                         (vop (intern (format nil "FAST-~A/~A=>~A"
+                                              fun regtype regtype)))
+                         (cvop (intern (format nil "FAST-~A-C/~A=>~A"
+                                               fun regtype regtype))))
+                     (forms `(define-modular-fun ,mfun-name (x y) ,fun ,width))
+                     (forms `(define-vop (,mvop ,vop)
+                              (:translate ,mfun-name)))
+                     (when constantp
+                       (forms `(define-vop (,mcvop ,cvop)
+                                (:translate ,mfun-name)))))))
+               `(progn ,@(forms)))))
   (define-modular-backend + t)
   (define-modular-backend - t)
   (define-modular-backend logxor t)
diff --git a/src/compiler/x86-64/arith.lisp b/src/compiler/x86-64/arith.lisp
index f549575..c0edde4 100644
--- a/src/compiler/x86-64/arith.lisp
+++ b/src/compiler/x86-64/arith.lisp
@@ -1234,21 +1234,34 @@
 
 ;;;; Modular functions
 
-(define-modular-fun +-mod64 (x y) + 64)
-(define-vop (fast-+-mod64/unsigned=>unsigned fast-+/unsigned=>unsigned)
-  (:translate +-mod64))
-(define-vop (fast-+-mod64-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned)
-  (:translate +-mod64))
-(define-modular-fun --mod64 (x y) - 64)
-(define-vop (fast---mod64/unsigned=>unsigned fast--/unsigned=>unsigned)
-  (:translate --mod64))
-(define-vop (fast---mod64-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
-  (:translate --mod64))
-
-(define-modular-fun *-mod64 (x y) * 64)
-(define-vop (fast-*-mod64/unsigned=>unsigned fast-*/unsigned=>unsigned)
-  (:translate *-mod64))
-;;; (no -C variant as x86 MUL instruction doesn't take an immediate)
+(macrolet ((define-modular-backend (fun &optional constantp)
+             (collect ((forms))
+               (dolist (info '((60 fixnum) (64 unsigned)))
+                 (destructuring-bind (width regtype) info
+                   (let ((mfun-name (intern (format nil "~A-MOD~A" fun width)))
+                         (mvop (intern (format nil "FAST-~A-MOD~A/~A=>~A"
+                                               fun width regtype regtype)))
+                         (mcvop (intern (format nil "FAST-~A-MOD~A-C/~A=>~A"
+                                                fun width regtype regtype)))
+                         (vop (intern (format nil "FAST-~A/~A=>~A"
+                                              fun regtype regtype)))
+                         (cvop (intern (format nil "FAST-~A-C/~A=>~A"
+                                               fun regtype regtype))))
+                     (forms `(define-modular-fun ,mfun-name (x y) ,fun ,width))
+                     (forms `(define-vop (,mvop ,vop)
+                              (:translate ,mfun-name)))
+                     (when constantp
+                       (forms `(define-vop (,mcvop ,cvop)
+                                (:translate ,mfun-name)))))))
+               `(progn ,@(forms)))))
+  (define-modular-backend + t)
+  (define-modular-backend - t)
+  (define-modular-backend *)            ; FIXME: there exists a
+                                        ; FAST-*-C/FIXNUM=>FIXNUM VOP which
+                                        ; should be used for the MOD60 case,
+                                        ; but the MOD64 case cannot accept
+                                        ; immediate arguments.
+  (define-modular-backend logxor t))
 
 (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
              fast-ash-c/unsigned=>unsigned)
@@ -1304,14 +1317,6 @@
     (move r x)
     (inst not r)))
 
-(define-modular-fun logxor-mod64 (x y) logxor 64)
-(define-vop (fast-logxor-mod64/unsigned=>unsigned
-             fast-logxor/unsigned=>unsigned)
-  (:translate logxor-mod64))
-(define-vop (fast-logxor-mod64-c/unsigned=>unsigned
-             fast-logxor-c/unsigned=>unsigned)
-  (:translate logxor-mod64))
-
 (define-source-transform logeqv (&rest args)
   (if (oddp (length args))
       `(logxor ,@args)
diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp
index ade7689..b45a958 100644
--- a/src/compiler/x86/arith.lisp
+++ b/src/compiler/x86/arith.lisp
@@ -1192,64 +1192,104 @@
 
 ;;;; Modular functions
 
-(define-modular-fun +-mod32 (x y) + 32)
-(define-vop (fast-+-mod32/unsigned=>unsigned fast-+/unsigned=>unsigned)
-  (:translate +-mod32))
-(define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned)
-  (:translate +-mod32))
-(define-modular-fun --mod32 (x y) - 32)
-(define-vop (fast---mod32/unsigned=>unsigned fast--/unsigned=>unsigned)
-  (:translate --mod32))
-(define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
-  (:translate --mod32))
-
-(define-modular-fun *-mod32 (x y) * 32)
-(define-vop (fast-*-mod32/unsigned=>unsigned fast-*/unsigned=>unsigned)
-  (:translate *-mod32))
-;;; (no -C variant as x86 MUL instruction doesn't take an immediate)
-
-(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
-             fast-ash-c/unsigned=>unsigned)
-  (:translate ash-left-mod32))
-
-(define-vop (fast-ash-left-mod32/unsigned=>unsigned
-             fast-ash-left/unsigned=>unsigned))
-(deftransform ash-left-mod32 ((integer count)
-			      ((unsigned-byte 32) (unsigned-byte 5)))
-  (when (sb!c::constant-lvar-p count)
-    (sb!c::give-up-ir1-transform))
-  '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
+(macrolet ((define-modular-backend (fun &optional constantp)
+             (collect ((forms))
+               (dolist (info '((29 fixnum) (32 unsigned)))
+                 (destructuring-bind (width regtype) info
+                   (let ((mfun-name (intern (format nil "~A-MOD~A" fun width)))
+                         (mvop (intern (format nil "FAST-~A-MOD~A/~A=>~A"
+                                               fun width regtype regtype)))
+                         (mcvop (intern (format nil "FAST-~A-MOD~A-C/~A=>~A"
+                                                fun width regtype regtype)))
+                         (vop (intern (format nil "FAST-~A/~A=>~A"
+                                              fun regtype regtype)))
+                         (cvop (intern (format nil "FAST-~A-C/~A=>~A"
+                                               fun regtype regtype))))
+                     (forms `(define-modular-fun ,mfun-name (x y) ,fun ,width))
+                     (forms `(define-vop (,mvop ,vop)
+                              (:translate ,mfun-name)))
+                     (when constantp
+                       (forms `(define-vop (,mcvop ,cvop)
+                                (:translate ,mfun-name)))))))
+               `(progn ,@(forms)))))
+  (define-modular-backend + t)
+  (define-modular-backend - t)
+  (define-modular-backend *)            ; FIXME: there exists a
+                                        ; FAST-*-C/FIXNUM=>FIXNUM VOP which
+                                        ; should be used for the MOD29 case,
+                                        ; but the MOD32 case cannot accept
+                                        ; immediate arguments.
+  (define-modular-backend logxor t))
+
+(macrolet ((define-modular-ash (width regtype)
+             (let ((mfun-name (intern (format nil "ASH-LEFT-MOD~A" width)))
+                   (modvop (intern (format nil "FAST-ASH-LEFT-MOD~A/~A=>~A"
+                                           width regtype regtype)))
+                   (modcvop (intern (format nil "FAST-ASH-LEFT-MOD~A-C/~A=>~A"
+                                            width regtype regtype)))
+                   (vop (intern (format nil "FAST-ASH-LEFT/~A=>~A"
+                                        regtype regtype)))
+                   (cvop (intern (format nil "FAST-ASH-C/~A=>~A"
+                                         regtype regtype))))
+               `(progn
+                 (define-vop (,modcvop ,cvop)
+                   (:translate ,mfun-name))
+                 (define-vop (,modvop ,vop))
+                 (deftransform ,mfun-name ((integer count)
+                                           ((unsigned-byte ,width) (unsigned-byte 5)))
+                   (when (sb!c::constant-lvar-p count)
+                     (sb!c::give-up-ir1-transform))
+                   '(%primitive ,modvop integer count))))))
+  (define-modular-ash 29 fixnum)
+  (define-modular-ash 32 unsigned))
 
 (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-mod29 (integer integer (member 1 2 4 8) (signed-byte 29))
+  (unsigned-byte 29)
+  (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))
+    (if (<= width 29)
+        'sb!vm::%lea-mod29
+        'sb!vm::%lea-mod32)))
 
 #+sb-xc-host
+(progn
+(defun sb!vm::%lea-mod29 (base index scale disp)
+  (ldb (byte 29 0) (%lea base index scale disp)))
 (defun sb!vm::%lea-mod32 (base index scale disp)
-  (ldb (byte 32 0) (%lea base index scale disp)))
+  (ldb (byte 32 0) (%lea base index scale disp))))
 #-sb-xc-host
+(progn
+(defun sb!vm::%lea-mod29 (base index scale disp)
+  (let ((base (logand base #x1fffffff))
+	(index (logand index #x1fffffff)))
+    ;; can't use modular version of %LEA, as we only have VOPs for
+    ;; constant SCALE and DISP.
+    (ldb (byte 29 0) (+ base (* index scale) disp))))
 (defun sb!vm::%lea-mod32 (base index scale disp)
   (let ((base (logand base #xffffffff))
 	(index (logand index #xffffffff)))
     ;; 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))))
+    (ldb (byte 32 0) (+ base (* index scale) disp)))))
 
 (in-package "SB!VM")
 
 (define-vop (%lea-mod32/unsigned=>unsigned
 	     %lea/unsigned=>unsigned)
   (:translate %lea-mod32))
+(define-vop (%lea-mod29/fixnum=>fixnum
+             %lea/fixnum=>fixnum)
+  (:translate %lea-mod29))
 
 ;;; logical operations
 (define-modular-fun lognot-mod32 (x) lognot 32)
@@ -1270,14 +1310,6 @@
     (move r x)
     (inst not r)))
 
-(define-modular-fun logxor-mod32 (x y) logxor 32)
-(define-vop (fast-logxor-mod32/unsigned=>unsigned
-             fast-logxor/unsigned=>unsigned)
-  (:translate logxor-mod32))
-(define-vop (fast-logxor-mod32-c/unsigned=>unsigned
-             fast-logxor-c/unsigned=>unsigned)
-  (:translate logxor-mod32))
-
 (define-source-transform logeqv (&rest args)
   (if (oddp (length args))
       `(logxor ,@args)
@@ -1602,37 +1634,37 @@
 ;;; 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.
-(defun basic-decompose-multiplication (arg num n-bits condensed)
+(defun basic-decompose-multiplication (arg num n-bits condensed mask)
   (case (aref condensed 0)
     (0
      (let ((tmp (min 3 (aref condensed 1))))
        (decf (aref condensed 1) tmp)
-       `(logand #xffffffff
-	 (%lea ,arg
-	       ,(decompose-multiplication
-		 arg (ash (1- num) (- tmp)) (1- n-bits) (subseq condensed 1))
-	       ,(ash 1 tmp) 0))))
+       `(logand ,mask (%lea ,arg
+                       ,(decompose-multiplication
+                         arg (ash (1- num) (- tmp)) (1- n-bits) (subseq condensed 1)
+                         mask)
+         ,(ash 1 tmp) 0))))
     ((1 2 3)
      (let ((r0 (aref condensed 0)))
        (incf (aref condensed 1) r0)
-       `(logand #xffffffff
-	 (%lea ,(decompose-multiplication
-		 arg (- num (ash 1 r0)) (1- n-bits) (subseq condensed 1))
-	       ,arg
-	       ,(ash 1 r0) 0))))
+       `(logand ,mask (%lea ,(decompose-multiplication
+                              arg (- num (ash 1 r0)) (1- n-bits) (subseq condensed 1)
+                              mask)
+                       ,arg
+                       ,(ash 1 r0) 0))))
     (t (let ((r0 (aref condensed 0)))
 	 (setf (aref condensed 0) 0)
-	 `(logand #xffffffff
-	   (ash ,(decompose-multiplication
-		  arg (ash num (- r0)) n-bits condensed)
-	        ,r0))))))
+	 `(logand ,mask (ash ,(decompose-multiplication
+                               arg (ash num (- r0)) n-bits condensed mask)
+           ,r0))))))
 
-(defun decompose-multiplication (arg num n-bits condensed)
+(defun decompose-multiplication (arg num n-bits condensed mask)
+                                     
   (cond
     ((= n-bits 0) 0)
     ((= num 1) arg)
     ((= n-bits 1)
-     `(logand #xffffffff (ash ,arg ,(1- (integer-length num)))))
+     `(logand ,mask (ash ,arg ,(1- (integer-length num)))))
     ((let ((max 0) (end 0))
        (loop for i from 2 to (length condensed)
 	     for j = (reduce #'+ (subseq condensed 0 i))
@@ -1641,25 +1673,24 @@
 			     (ash (ldb (byte (- 32 (1+ j)) (1+ j)) num)
 				  (1+ j)))
 			  (ash 1 32)))
-	       do (setq max (- (* 2 i) 3 j)
-			end i))
+             do (setq max (- (* 2 i) 3 j)
+                      end i))
        (when (> max 0)
 	 (let ((j (reduce #'+ (subseq condensed 0 end))))
 	   (let ((n2 (+ (ash 1 (1+ j))
 			(ash (ldb (byte (- 32 (1+ j)) (1+ j)) num) (1+ j))))
 		 (n1 (1+ (ldb (byte (1+ j) 0) (lognot num)))))
-	   `(logand #xffffffff
-	     (- ,(optimize-multiply arg n2) ,(optimize-multiply arg n1))))))))
+             `(logand ,mask (- ,(optimize-multiply arg n2 mask)
+                             ,(optimize-multiply arg n1 mask))))))))
     ((dolist (i '(9 5 3))
        (when (integerp (/ num i))
 	 (when (< (logcount (/ num i)) (logcount num))
 	   (let ((x (gensym)))
-	     (return `(let ((,x ,(optimize-multiply arg (/ num i))))
-		       (logand #xffffffff
-			(%lea ,x ,x (1- ,i) 0)))))))))
-    (t (basic-decompose-multiplication arg num n-bits condensed))))
+	     (return `(let ((,x ,(optimize-multiply arg (/ num i) mask)))
+		       (logand ,mask (%lea ,x ,x (1- ,i) 0)))))))))
+    (t (basic-decompose-multiplication arg num n-bits condensed mask))))
 	   
-(defun optimize-multiply (arg x)
+(defun optimize-multiply (arg x mask)
   (let* ((n-bits (logcount x))
 	 (condensed (make-array n-bits)))
     (let ((count 0) (bit 0))
@@ -1669,9 +1700,9 @@
 	       (setf count 1)
 	       (incf bit))
 	      (t (incf count)))))
-    (decompose-multiplication arg x n-bits condensed)))
+    (decompose-multiplication arg x n-bits condensed mask)))
 
-(defun *-transformer (y)
+(defun *-transformer (y mask)
   (cond
     ((= y (ash 1 (integer-length y)))
      ;; there's a generic transform for y = 2^k
@@ -1685,21 +1716,53 @@
     ;; FIXME: should make this more fine-grained.  If nothing else,
     ;; there should probably be a cutoff of about 9 instructions on
     ;; pentium-class machines.
-    (t (optimize-multiply 'x y))))
-
+    (t (optimize-multiply 'x y mask))))
+
+;;; KLUDGE: due to the manner in which DEFTRANSFORM is implemented, it
+;;; is vitally important that the transform for (UNSIGNED-BYTE 29)
+;;; multiply come after the transform for (UNSIGNED-BYTE 32) multiply.
+;;; When attempting to transform a function application, the compiler
+;;; examines the relevant transforms for the function in the reverse
+;;; order in which they were defined and takes the first one which
+;;; succeeds.  If the (UNSIGNED-BYTE 32) transform were to come after
+;;; the (UNSIGNED-BYTE 29) transform, the (UNSIGNED-BYTE 32) transform
+;;; would be attempted first.  Since (UNSIGNED-BYTE 29) is subsumed by
+;;; (UNSIGNED-BYTE 32), and assuming the arguments and result are
+;;; (UNSIGNED-BYTE 29)s, the (UNSIGNED-BYTE 32) transform would succeed
+;;; and force (UNSIGNED-BYTE 32) arithmetic where (UNSIGNED-BYTE 29)
+;;; arithmetic would work perfectly well--introducing unnecessary
+;;; shifting and causing efficiency notes where the user might not
+;;; expect them to occur.  So we define the (UNSIGNED-BYTE 29) transform
+;;; *after* the (UNSIGNED-BYTE 32) transform in order to attempt the
+;;; (UNSIGNED-BYTE 29) transform *before* the (UNSIGNED-BYTE 32)
+;;; transform.  Yuck.   -- njf, 2004-12-07
 (deftransform * ((x y)
 		 ((unsigned-byte 32) (constant-arg (unsigned-byte 32)))
 		 (unsigned-byte 32))
   "recode as leas, shifts and adds"
   (let ((y (lvar-value y)))
-    (*-transformer y)))
+    (*-transformer y #xffffffff)))
+
+(deftransform * ((x y)
+                 ((unsigned-byte 29) (constant-arg (unsigned-byte 29)))
+                 (unsigned-byte 29))
+  "recode as leas, shifts, and adds"
+  (let ((y (lvar-value y)))
+    (*-transformer y #x1fffffff)))
 
 (deftransform sb!vm::*-mod32
     ((x y) ((unsigned-byte 32) (constant-arg (unsigned-byte 32)))
      (unsigned-byte 32))
   "recode as leas, shifts and adds"
   (let ((y (lvar-value y)))
-    (*-transformer y)))
+    (*-transformer y #xffffffff)))
+
+(deftransform sb!vm::*-mod29
+    ((x y) ((unsigned-byte 29) (constant-arg (unsigned-byte 29)))
+     (unsigned-byte 29))
+  "recode as leas, shifts and adds"
+  (let ((y (lvar-value y)))
+    (*-transformer y #x1fffffff)))
 
 ;;; FIXME: we should also be able to write an optimizer or two to
 ;;; convert (+ (* x 2) 17), (- (* x 9) 5) to a %LEA.
diff --git a/version.lisp-expr b/version.lisp-expr
index bd08f64..5da8755 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.17.23"
+"0.8.17.24"