From: Alexey Dejneka <adejneka@comail.ru>
Date: Sun, 19 Dec 2004 07:01:04 +0000 (+0000)
Subject: 0.8.17.29:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=cb79d726de3e18c660f84c58a43f00d22b459037;p=sbcl.git

0.8.17.29:
        * Merged sbcl-0-8-17-28-signed-modular branch.
---

diff --git a/src/code/cross-byte.lisp b/src/code/cross-byte.lisp
index b9b8178..4b6f4a2 100644
--- a/src/code/cross-byte.lisp
+++ b/src/code/cross-byte.lisp
@@ -39,6 +39,11 @@
 (defun sb!xc:deposit-field (new cross-byte int)
   (cl:deposit-field new (uncross-byte cross-byte) int))
 
+(defun sb!c::mask-signed-field (size integer)
+  (if (logbitp (1- size) integer)
+      (dpb integer (byte size 0) -1)
+      (ldb (byte size 0) integer)))
+
 (define-setf-expander sb!xc:ldb (cross-byte int &environment env)
   (multiple-value-bind (temps vals stores store-form access-form)
       (get-setf-expansion int env)
diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index 330fcdd..16929b1 100644
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -1161,6 +1161,18 @@ the first."
   (let ((mask (ash (ldb (byte size 0) -1) posn)))
     (logior (logand newbyte mask)
 	    (logand integer (lognot mask)))))
+
+(defun sb!c::mask-signed-field (size integer)
+  #!+sb-doc
+  "Extract SIZE lower bits from INTEGER, considering them as a
+2-complement SIZE-bits representation of a signed integer."
+  (cond ((zerop size)
+         0)
+        ((logbitp (1- size) integer)
+         (dpb integer (byte size 0) -1))
+        (t
+         (ldb (byte size 0) integer))))
+
 
 ;;;; BOOLE
 
@@ -1404,7 +1416,7 @@ the first."
                          (bignum (logand x ,pattern)))))
                 (,name ,@(loop for arg in lambda-list
                                collect `(prepare-argument ,arg)))))))
-    (loop for infos being each hash-value of sb!c::*modular-funs*
+    (loop for infos being each hash-value of (sb!c::modular-class-funs sb!c::*unsigned-modular-class*)
           ;; FIXME: We need to process only "toplevel" functions
           when (listp infos)
           do (loop for info in infos
@@ -1415,6 +1427,28 @@ the first."
                    do (forms (definition name lambda-list width pattern)))))
   `(progn ,@(forms)))
 
+#.
+(collect ((forms))
+  (flet ((definition (name lambda-list width)
+           `(defun ,name ,lambda-list
+              (flet ((prepare-argument (x)
+                       (declare (integer x))
+                       (etypecase x
+                         ((signed-byte ,width) x)
+                         (fixnum (sb!c::mask-signed-field ,width x))
+                         (bignum (sb!c::mask-signed-field ,width x)))))
+                (,name ,@(loop for arg in lambda-list
+                               collect `(prepare-argument ,arg)))))))
+    (loop for infos being each hash-value of (sb!c::modular-class-funs sb!c::*signed-modular-class*)
+          ;; FIXME: We need to process only "toplevel" functions
+          when (listp infos)
+          do (loop for info in infos
+                   for name = (sb!c::modular-fun-info-name info)
+                   and width = (sb!c::modular-fun-info-width info)
+                   and lambda-list = (sb!c::modular-fun-info-lambda-list info)
+                   do (forms (definition name lambda-list width)))))
+  `(progn ,@(forms)))
+
 ;;; KLUDGE: these out-of-line definitions can't use the modular
 ;;; arithmetic, as that is only (currently) defined for constant
 ;;; shifts.  See also the comment in (LOGAND OPTIMIZER) for more
@@ -1432,3 +1466,9 @@ the first."
     (fixnum (ldb (byte 64 0) (ash (logand integer #xffffffffffffffff) amount)))
     (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)))))
diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index 5ff9427..cb22831 100644
--- a/src/compiler/aliencomp.lisp
+++ b/src/compiler/aliencomp.lisp
@@ -521,7 +521,7 @@
 	 (count-low-order-zeros (lvar-uses thing))))
     (combination
      (case (let ((name (lvar-fun-name (combination-fun thing))))
-             (or (modular-version-info name) name))
+             (or (modular-version-info name :unsigned) name))
        ((+ -)
 	(let ((min most-positive-fixnum)
 	      (itype (specifier-type 'integer)))
@@ -578,7 +578,7 @@
       (give-up-ir1-transform))
     (let ((inside-fun-name (lvar-fun-name (combination-fun value-node))))
       (multiple-value-bind (prototype width)
-          (modular-version-info inside-fun-name)
+          (modular-version-info inside-fun-name :unsigned)
         (unless (eq (or prototype inside-fun-name) 'ash)
           (give-up-ir1-transform))
         (when (and width (not (constant-lvar-p amount)))
diff --git a/src/compiler/alpha/arith.lisp b/src/compiler/alpha/arith.lisp
index e8c0586..4c3d931 100644
--- a/src/compiler/alpha/arith.lisp
+++ b/src/compiler/alpha/arith.lisp
@@ -389,7 +389,7 @@
     (inst mulq x y r)))
 
 ;;;; Modular functions:
-(define-modular-fun lognot-mod64 (x) lognot 64)
+(define-modular-fun lognot-mod64 (x) lognot :unsigned 64)
 (define-vop (lognot-mod64/unsigned=>unsigned)
   (:translate lognot-mod64)
   (:args (x :scs (unsigned-reg)))
@@ -419,7 +419,7 @@
              (vop (symbolicate 'fast- fun '/unsigned=>unsigned))
              (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
          `(progn
-            (define-modular-fun ,mfun-name (x y) ,fun 64)
+            (define-modular-fun ,mfun-name (x y) ,fun :unsigned 64)
             (define-vop (,modvop ,vop)
               (:translate ,mfun-name))
             ,@(when constantp
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 8939dbc..d98fc92 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -1343,6 +1343,8 @@
 ;;;; miscellaneous extensions
 
 (defknown get-bytes-consed () unsigned-byte (flushable))
+(defknown mask-signed-field ((integer 0 *) integer) integer
+          (movable flushable foldable))
 
 ;;; PCOUNTERs
 (defknown incf-pcounter (pcounter unsigned-byte) pcounter)
diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp
index 66d399a..ae21559 100644
--- a/src/compiler/generic/vm-macs.lisp
+++ b/src/compiler/generic/vm-macs.lisp
@@ -153,26 +153,31 @@
 
 ;;; For a documentation, see CUT-TO-WIDTH.
 
-;;; hash: name -> { :GOOD | optimizer | ({modular-fun-info}*)}
-(defvar *modular-funs*
-  (make-hash-table :test 'eq))
+(defstruct modular-class
+  ;; hash: name -> { :GOOD | optimizer | ({modular-fun-info}*)}
+  (funs (make-hash-table :test 'eq))
+  ;; hash: modular-variant -> (prototype width)
+  ;;
+  ;; FIXME: Reimplement with generic function names of kind
+  ;; (MODULAR-VERSION prototype width)
+  (versions (make-hash-table :test 'eq))
+  ;; list of increasing widths
+  (widths nil))
+(defvar *unsigned-modular-class* (make-modular-class))
+(defvar *signed-modular-class* (make-modular-class))
+(defun find-modular-class (kind)
+  (ecase kind
+    (:unsigned *unsigned-modular-class*)
+    (:signed *signed-modular-class*)))
 
-;;; hash: modular-variant -> (prototype width)
-;;;
-;;; FIXME: Reimplement with generic function names of kind
-;;; (MODULAR-VERSION prototype width)
-(defvar *modular-versions* (make-hash-table :test 'eq))
-
-;;; List of increasing widths
-(defvar *modular-funs-widths* nil)
 (defstruct modular-fun-info
   (name (missing-arg) :type symbol)
   (width (missing-arg) :type (integer 0))
   (lambda-list (missing-arg) :type list)
   (prototype (missing-arg) :type symbol))
 
-(defun find-modular-version (fun-name width)
-  (let ((infos (gethash fun-name *modular-funs*)))
+(defun find-modular-version (fun-name class width)
+  (let ((infos (gethash fun-name (modular-class-funs (find-modular-class class)))))
     (if (listp infos)
         (find-if (lambda (item-width) (>= item-width width))
                  infos
@@ -180,11 +185,14 @@
         infos)))
 
 ;;; Return (VALUES prototype-name width)
-(defun modular-version-info (name)
-  (values-list (gethash name *modular-versions*)))
+(defun modular-version-info (name class)
+  (values-list (gethash name (modular-class-versions (find-modular-class class)))))
 
-(defun %define-modular-fun (name lambda-list prototype width)
-  (let* ((infos (the list (gethash prototype *modular-funs*)))
+(defun %define-modular-fun (name lambda-list prototype class width)
+  (let* ((class (find-modular-class class))
+         (funs (modular-class-funs class))
+         (versions (modular-class-versions class))
+         (infos (the list (gethash prototype funs)))
          (info (find-if (lambda (item-width) (= item-width width))
                         infos
                         :key #'modular-fun-info-width)))
@@ -195,7 +203,7 @@
           (setf (modular-fun-info-name info) name)
           (style-warn "Redefining modular version ~S of ~S for width ~S."
                       name prototype width))
-        (setf (gethash prototype *modular-funs*)
+        (setf (gethash prototype funs)
               (merge 'list
                      (list (make-modular-fun-info :name name
                                                   :width width
@@ -203,43 +211,51 @@
                                                   :prototype prototype))
                      infos
                      #'< :key #'modular-fun-info-width)
-              (gethash name *modular-versions*)
-              (list prototype width))))
-  (setq *modular-funs-widths*
-        (merge 'list (list width) *modular-funs-widths* #'<)))
+              (gethash name versions)
+              (list prototype width)))
+    (setf (modular-class-widths class)
+          (merge 'list (list width) (modular-class-widths class) #'<))))
 
-(defmacro define-modular-fun (name lambda-list prototype width)
+(defmacro define-modular-fun (name lambda-list prototype class width)
   (check-type name symbol)
   (check-type prototype symbol)
+  (check-type class (member :unsigned :signed))
   (check-type width unsigned-byte)
   (dolist (arg lambda-list)
     (when (member arg lambda-list-keywords)
       (error "Lambda list keyword ~S is not supported for ~
               modular function lambda lists." arg)))
   `(progn
-     (%define-modular-fun ',name ',lambda-list ',prototype ,width)
+     (%define-modular-fun ',name ',lambda-list ',prototype ',class ,width)
      (defknown ,name ,(mapcar (constantly 'integer) lambda-list)
-               (unsigned-byte ,width)
-               (foldable flushable movable))))
+               (,(ecase class
+                   (:unsigned 'unsigned-byte)
+                   (:signed 'signed-byte))
+                 ,width)
+               (foldable flushable movable)
+               :derive-type (make-modular-fun-type-deriver
+                             ',prototype ',class ,width))))
 
-(defun %define-good-modular-fun (name)
-  (setf (gethash name *modular-funs*) :good)
+(defun %define-good-modular-fun (name class)
+  (setf (gethash name (modular-class-funs (find-modular-class class))) :good)
   name)
 
-(defmacro define-good-modular-fun (name)
+(defmacro define-good-modular-fun (name class)
   (check-type name symbol)
-  `(%define-good-modular-fun ',name))
+  (check-type class (member :unsigned :signed))
+  `(%define-good-modular-fun ',name ',class))
 
 (defmacro define-modular-fun-optimizer
-    (name ((&rest lambda-list) &key (width (gensym "WIDTH")))
+    (name ((&rest lambda-list) class &key (width (gensym "WIDTH")))
      &body body)
   (check-type name symbol)
+  (check-type class (member :unsigned :signed))
   (dolist (arg lambda-list)
     (when (member arg lambda-list-keywords)
       (error "Lambda list keyword ~S is not supported for ~
               modular function lambda lists." arg)))
   (with-unique-names (call args)
-    `(setf (gethash ',name *modular-funs*)
+    `(setf (gethash ',name (modular-class-funs (find-modular-class ',class)))
            (lambda (,call ,width)
              (declare (type basic-combination ,call)
                       (type (integer 0) width))
diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index e47aec5..6890462 100644
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -488,32 +488,37 @@
 
 
 ;;;; modular functions
-(define-good-modular-fun logand)
-(define-good-modular-fun logior)
+(define-good-modular-fun logand :unsigned)
+(define-good-modular-fun logior :unsigned)
 ;;; FIXME: XOR? ANDC1, ANDC2?  -- CSR, 2003-09-16
 
 (macrolet
-    ((def (name width)
+    ((def (name class width)
+       (let ((type (ecase class
+                     (:unsigned 'unsigned-byte)
+                     (:signed 'signed-byte))))
 	 `(progn
-	    (defknown ,name (integer (integer 0)) (unsigned-byte ,width)
-		      (foldable flushable movable))	   
-	    (define-modular-fun-optimizer ash ((integer count) :width width)
+	    (defknown ,name (integer (integer 0)) (,type ,width)
+		      (foldable flushable movable))
+	    (define-modular-fun-optimizer ash ((integer count) ,class :width width)
 	      (when (and (<= width ,width)
 			 (or (and (constant-lvar-p count)
 				  (plusp (lvar-value count)))
 			     (csubtypep (lvar-type count)
-					(specifier-type '(and unsigned-byte
-							  fixnum)))))
-		(cut-to-width integer width)
+					(specifier-type '(and unsigned-byte fixnum)))))
+		(cut-to-width integer ,class width)
 		',name))
-	    (setf (gethash ',name *modular-versions*) `(ash ,',width)))))
+            (setf (gethash ',name (modular-class-versions (find-modular-class ',class)))
+                  `(ash ,',width))))))
   ;; 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))
-  (def sb!vm::ash-left-mod32 32)
+  (progn
+    #!+x86 (def sb!vm::ash-left-smod30 :signed 30)
+    (def sb!vm::ash-left-mod32 :unsigned 32))
   #!+#.(cl:if (cl:= 64 sb!vm:n-machine-word-bits) '(and) '(or))
-  (def sb!vm::ash-left-mod64 64))
+  (def sb!vm::ash-left-mod64 :unsigned 64))
 
 
 ;;;; word-wise logical operations
diff --git a/src/compiler/hppa/arith.lisp b/src/compiler/hppa/arith.lisp
index 78b3f53..cafd2a3 100644
--- a/src/compiler/hppa/arith.lisp
+++ b/src/compiler/hppa/arith.lisp
@@ -580,12 +580,12 @@
   
 
 ;;;; modular functions
-(define-modular-fun +-mod32 (x y) + 32)
+(define-modular-fun +-mod32 (x y) + :unsigned 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-modular-fun --mod32 (x y) - :unsigned 32)
 (define-vop (fast---mod32/unsigned=>unsigned fast--/unsigned=>unsigned)
   (:translate --mod32))
 (define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
@@ -604,7 +604,7 @@
     (sb!c::give-up-ir1-transform))
   '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
 
-(define-modular-fun lognot-mod32 (x) lognot 32)
+(define-modular-fun lognot-mod32 (x) lognot :unsigned 32)
 (define-vop (lognot-mod32/unsigned=>unsigned)
   (:translate lognot-mod32)
   (:args (x :scs (unsigned-reg)))
@@ -623,7 +623,7 @@
 	     (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
 	     (vop (symbolicate 'fast- fun '/unsigned=>unsigned)))
 	 `(progn
-	    (define-modular-fun ,mfun-name (x y) ,fun 32)
+	    (define-modular-fun ,mfun-name (x y) ,fun :unsigned 32)
 	    (define-vop (,modvop ,vop)
 	      (:translate ,mfun-name))))))
   (define-modular-backend logxor)
diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 73a3247..3d06bd0 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -195,24 +195,12 @@
 (defun assert-lvar-type (lvar type policy)
   (declare (type lvar lvar) (type ctype type))
   (unless (values-subtypep (lvar-derived-type lvar) type)
-    (let* ((dest (lvar-dest lvar))
-           (ctran (node-prev dest)))
-      (with-ir1-environment-from-node dest
-        (let* ((cast (make-cast lvar type policy))
-               (internal-lvar (make-lvar))
-               (internal-ctran (make-ctran)))
-          (setf (ctran-next ctran) cast
-                (node-prev cast) ctran)
-          (use-continuation cast internal-ctran internal-lvar)
-          (link-node-to-previous-ctran dest internal-ctran)
-          (substitute-lvar internal-lvar lvar)
-          (setf (lvar-dest lvar) cast)
-          (reoptimize-lvar lvar)
-          (when (return-p dest)
-            (node-ends-block cast))
-          (setf (block-attributep (block-flags (node-block cast))
-                                  type-check type-asserted)
-                t))))))
+    (let ((internal-lvar (make-lvar))
+          (dest (lvar-dest lvar)))
+      (substitute-lvar internal-lvar lvar)
+      (let ((cast (insert-cast-before dest lvar type policy)))
+        (use-lvar cast internal-lvar))))
+  (values))
 
 
 ;;;; IR1-OPTIMIZE
@@ -1352,11 +1340,24 @@
               t))
            (eq (node-home-lambda ref)
                (lambda-home (lambda-var-home var))))
+      (let ((ref-type (single-value-type (node-derived-type ref))))
+        (cond ((csubtypep (single-value-type (lvar-type arg)) ref-type)
+               (substitute-lvar-uses lvar arg
+                                     ;; Really it is (EQ (LVAR-USES LVAR) REF):
+                                     t)
+               (delete-lvar-use ref))
+              (t
+               (let* ((value (make-lvar))
+                      (cast (insert-cast-before ref value ref-type
+                                                ;; KLUDGE: it should be (TYPE-CHECK 0)
+                                                *policy*)))
+                 (setf (cast-type-to-check cast) *wild-type*)
+                 (substitute-lvar-uses value arg
+                                     ;; FIXME
+                                     t)
+                 (%delete-lvar-use ref)
+                 (add-lvar-use cast lvar)))))
       (setf (node-derived-type ref) *wild-type*)
-      (substitute-lvar-uses lvar arg
-                            ;; Really it is (EQ (LVAR-USES LVAR) REF):
-                            t)
-      (delete-lvar-use ref)
       (change-ref-leaf ref (find-constant nil))
       (delete-ref ref)
       (unlink-node ref)
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index a5e8c16..1e92d4e 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -325,6 +325,26 @@
                     (merge-tail-sets merge)))))
         (t (flush-dest value)
            (unlink-node node))))
+
+;;; Make a CAST and insert it into IR1 before node NEXT.
+(defun insert-cast-before (next lvar type policy)
+  (declare (type node next) (type lvar lvar) (type ctype type))
+  (with-ir1-environment-from-node next
+    (let* ((ctran (node-prev next))
+           (cast (make-cast lvar type policy))
+           (internal-ctran (make-ctran)))
+      (setf (ctran-next ctran) cast
+            (node-prev cast) ctran)
+      (use-ctran cast internal-ctran)
+      (link-node-to-previous-ctran next internal-ctran)
+      (setf (lvar-dest lvar) cast)
+      (reoptimize-lvar lvar)
+      (when (return-p next)
+        (node-ends-block cast))
+      (setf (block-attributep (block-flags (node-block cast))
+                              type-check type-asserted)
+            t)
+      cast)))
 
 ;;;; miscellaneous shorthand functions
 
diff --git a/src/compiler/mips/arith.lisp b/src/compiler/mips/arith.lisp
index 9ae3a64..9d13c93 100644
--- a/src/compiler/mips/arith.lisp
+++ b/src/compiler/mips/arith.lisp
@@ -667,12 +667,12 @@
        (inst sll r num amount)))))
 
 ;;;; Modular arithmetic
-(define-modular-fun +-mod32 (x y) + 32)
+(define-modular-fun +-mod32 (x y) + :unsigned 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-modular-fun --mod32 (x y) - :unsigned 32)
 (define-vop (fast---mod32/unsigned=>unsigned fast--/unsigned=>unsigned)
   (:translate --mod32))
 (define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
@@ -691,7 +691,7 @@
   '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
 
 ;;; logical operations
-(define-modular-fun lognot-mod32 (x) lognot 32)
+(define-modular-fun lognot-mod32 (x) lognot :unsigned 32)
 (define-vop (lognot-mod32/unsigned=>unsigned)
   (:translate lognot-mod32)
   (:args (x :scs (unsigned-reg)))
@@ -702,7 +702,7 @@
   (:generator 1
     (inst nor r x zero-tn)))
 
-(define-modular-fun logxor-mod32 (x y) logxor 32)
+(define-modular-fun logxor-mod32 (x y) logxor :unsigned 32)
 (define-vop (fast-logxor-mod32/unsigned=>unsigned
              fast-logxor/unsigned=>unsigned)
   (:translate logxor-mod32))
@@ -710,7 +710,7 @@
              fast-logxor-c/unsigned=>unsigned)
   (:translate logxor-mod32))
 
-(define-modular-fun lognor-mod32 (x y) lognor 32)
+(define-modular-fun lognor-mod32 (x y) lognor :unsigned 32)
 (define-vop (fast-lognor-mod32/unsigned=>unsigned
 	     fast-lognor/unsigned=>unsigned)
   (:translate lognor-mod32))
diff --git a/src/compiler/ppc/arith.lisp b/src/compiler/ppc/arith.lisp
index 369b0e8..28d4acb 100644
--- a/src/compiler/ppc/arith.lisp
+++ b/src/compiler/ppc/arith.lisp
@@ -460,7 +460,7 @@
 
 
 ;;;; Modular functions:
-(define-modular-fun lognot-mod32 (x) lognot 32)
+(define-modular-fun lognot-mod32 (x) lognot :unsigned 32)
 (define-vop (lognot-mod32/unsigned=>unsigned)
   (:translate lognot-mod32)
   (:args (x :scs (unsigned-reg)))
@@ -491,7 +491,7 @@
 	     (vop (symbolicate 'fast- fun '/unsigned=>unsigned))
 	     (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
 	 `(progn
-	    (define-modular-fun ,mfun-name (x y) ,fun 32)
+	    (define-modular-fun ,mfun-name (x y) ,fun :unsigned 32)
 	    (define-vop (,modvop ,vop)
 	      (:translate ,mfun-name))
 	    ,@(when constantp
diff --git a/src/compiler/sparc/arith.lisp b/src/compiler/sparc/arith.lisp
index 1f40039..3da21a6 100644
--- a/src/compiler/sparc/arith.lisp
+++ b/src/compiler/sparc/arith.lisp
@@ -647,7 +647,7 @@
 
 
 ;;;; Modular functions:
-(define-modular-fun lognot-mod32 (x) lognot 32)
+(define-modular-fun lognot-mod32 (x) lognot :unsigned 32)
 (define-vop (lognot-mod32/unsigned=>unsigned)
   (:translate lognot-mod32)
   (:args (x :scs (unsigned-reg)))
@@ -666,7 +666,7 @@
              (vop (symbolicate 'fast- fun '/unsigned=>unsigned))
              (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
          `(progn
-            (define-modular-fun ,mfun-name (x y) ,fun 32)
+            (define-modular-fun ,mfun-name (x y) ,fun :unsigned 32)
             (define-vop (,modvop ,vop)
               (:translate ,mfun-name))
 	    ,@(when constantp
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index c1da98b..e3f1985 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2551,6 +2551,16 @@
   `(let ((mask (ash (ldb (byte size 0) -1) posn)))
      (logior (logand new mask)
 	     (logand int (lognot mask)))))
+
+(defoptimizer (mask-signed-field derive-type) ((size x))
+  (let ((size (lvar-type size)))
+    (if (numeric-type-p size)
+	(let ((size-high (numeric-type-high size)))
+	  (if (and size-high (<= 1 size-high sb!vm:n-word-bits))
+	      (specifier-type `(signed-byte ,size-high))
+	      *universal-type*))
+	*universal-type*)))
+
 
 ;;; Modular functions
 
@@ -2559,6 +2569,31 @@
 ;;;
 ;;; and similar for other arguments.
 
+(defun make-modular-fun-type-deriver (prototype class width)
+  #!-sb-fluid
+  (binding* ((info (info :function :info prototype) :exit-if-null)
+             (fun (fun-info-derive-type info) :exit-if-null)
+             (mask-type (specifier-type
+                         (ecase class
+                             (:unsigned `(unsigned-byte* ,width))
+                             (:signed `(signed-byte ,width))))))
+    (lambda (call)
+      (let ((res (funcall fun call)))
+        (when res
+          (if (eq class :unsigned)
+              (logand-derive-type-aux res mask-type))))))
+  #!+sb-fluid
+  (lambda (call)
+    (binding* ((info (info :function :info prototype) :exit-if-null)
+               (fun (fun-info-derive-type info) :exit-if-null)
+               (res (funcall fun call) :exit-if-null)
+               (mask-type (specifier-type
+                           (ecase class
+                             (:unsigned `(unsigned-byte* ,width))
+                             (:signed `(signed-byte ,width))))))
+      (if (eq class :unsigned)
+          (logand-derive-type-aux res mask-type)))))
+
 ;;; Try to recursively cut all uses of LVAR to WIDTH bits.
 ;;;
 ;;; For good functions, we just recursively cut arguments; their
@@ -2571,54 +2606,59 @@
 ;;; modular version, if it exists, or NIL. If we have changed
 ;;; anything, we need to flush old derived types, because they have
 ;;; nothing in common with the new code.
-(defun cut-to-width (lvar width)
+(defun cut-to-width (lvar class width)
   (declare (type lvar lvar) (type (integer 0) width))
-  (labels ((reoptimize-node (node name)
-             (setf (node-derived-type node)
-                   (fun-type-returns
-                    (info :function :type name)))
-             (setf (lvar-%derived-type (node-lvar node)) nil)
-             (setf (node-reoptimize node) t)
-             (setf (block-reoptimize (node-block node)) t)
-             (reoptimize-component (node-component node) :maybe))
-           (cut-node (node &aux did-something)
-             (when (and (not (block-delete-p (node-block node)))
-                        (combination-p node)
-			(eq (basic-combination-kind node) :known))
-               (let* ((fun-ref (lvar-use (combination-fun node)))
-                      (fun-name (leaf-source-name (ref-leaf fun-ref)))
-                      (modular-fun (find-modular-version fun-name width)))
-                 (when (and modular-fun
-                            (not (and (eq fun-name 'logand)
-                                      (csubtypep
-                                       (single-value-type (node-derived-type node))
-                                       (specifier-type `(unsigned-byte* ,width))))))
-                   (binding* ((name (etypecase modular-fun
-                                      ((eql :good) fun-name)
-                                      (modular-fun-info
-                                       (modular-fun-info-name modular-fun))
-                                      (function
-                                       (funcall modular-fun node width)))
-                                :exit-if-null))
-                     (unless (eql modular-fun :good)
-                       (setq did-something t)
-                       (change-ref-leaf
-                        fun-ref
-                        (find-free-fun name "in a strange place"))
-                       (setf (combination-kind node) :full))
-                     (unless (functionp modular-fun)
-                       (dolist (arg (basic-combination-args node))
-                         (when (cut-lvar arg)
-                           (setq did-something t))))
-                     (when did-something
-                       (reoptimize-node node name))
-                     did-something)))))
-           (cut-lvar (lvar &aux did-something)
-             (do-uses (node lvar)
-               (when (cut-node node)
-                 (setq did-something t)))
-             did-something))
-    (cut-lvar lvar)))
+  (let ((type (specifier-type (if (zerop width)
+                                  '(eql 0)
+                                  `(,(ecase class (:unsigned 'unsigned-byte)
+                                            (:signed 'signed-byte))
+                                     ,width)))))
+    (labels ((reoptimize-node (node name)
+               (setf (node-derived-type node)
+                     (fun-type-returns
+                      (info :function :type name)))
+               (setf (lvar-%derived-type (node-lvar node)) nil)
+               (setf (node-reoptimize node) t)
+               (setf (block-reoptimize (node-block node)) t)
+               (reoptimize-component (node-component node) :maybe))
+             (cut-node (node &aux did-something)
+               (when (and (not (block-delete-p (node-block node)))
+                          (combination-p node)
+                          (eq (basic-combination-kind node) :known))
+                 (let* ((fun-ref (lvar-use (combination-fun node)))
+                        (fun-name (leaf-source-name (ref-leaf fun-ref)))
+                        (modular-fun (find-modular-version fun-name class width)))
+                   (when (and modular-fun
+                              (not (and (eq fun-name 'logand)
+                                        (csubtypep
+                                         (single-value-type (node-derived-type node))
+                                         type))))
+                     (binding* ((name (etypecase modular-fun
+                                        ((eql :good) fun-name)
+                                        (modular-fun-info
+                                         (modular-fun-info-name modular-fun))
+                                        (function
+                                         (funcall modular-fun node width)))
+                                      :exit-if-null))
+                               (unless (eql modular-fun :good)
+                                 (setq did-something t)
+                                 (change-ref-leaf
+                                  fun-ref
+                                  (find-free-fun name "in a strange place"))
+                                 (setf (combination-kind node) :full))
+                               (unless (functionp modular-fun)
+                                 (dolist (arg (basic-combination-args node))
+                                   (when (cut-lvar arg)
+                                     (setq did-something t))))
+                               (when did-something
+                                 (reoptimize-node node name))
+                               did-something)))))
+             (cut-lvar (lvar &aux did-something)
+               (do-uses (node lvar)
+                 (when (cut-node node)
+                   (setq did-something t)))
+               did-something))
+      (cut-lvar lvar))))
 
 (defoptimizer (logand optimizer) ((x y) node)
   (let ((result-type (single-value-type (node-derived-type node))))
@@ -2630,10 +2670,24 @@
                    (>= low 0))
           (let ((width (integer-length high)))
             (when (some (lambda (x) (<= width x))
-                        *modular-funs-widths*)
+                        (modular-class-widths *unsigned-modular-class*))
               ;; FIXME: This should be (CUT-TO-WIDTH NODE WIDTH).
-              (cut-to-width x width)
-              (cut-to-width y width)
+              (cut-to-width x :unsigned width)
+              (cut-to-width y :unsigned width)
+              nil ; After fixing above, replace with T.
+              )))))))
+
+(defoptimizer (mask-signed-field optimizer) ((width x) node)
+  (let ((result-type (single-value-type (node-derived-type node))))
+    (when (numeric-type-p result-type)
+      (let ((low (numeric-type-low result-type))
+            (high (numeric-type-high result-type)))
+        (when (and (numberp low) (numberp high))
+          (let ((width (max (integer-length high) (integer-length low))))
+            (when (some (lambda (x) (<= width x))
+                        (modular-class-widths *signed-modular-class*))
+              ;; FIXME: This should be (CUT-TO-WIDTH NODE WIDTH).
+              (cut-to-width x :signed width)
               nil ; After fixing above, replace with T.
               )))))))
 
@@ -2801,6 +2855,13 @@
       (give-up-ir1-transform))
     'x))
 
+(deftransform mask-signed-field ((size x) ((constant-arg t) *) *)
+  "fold identity operation"
+  (let ((size (lvar-value size)))
+    (unless (csubtypep (lvar-type x) (specifier-type `(signed-byte ,size)))
+      (give-up-ir1-transform))
+    'x))
+
 ;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
 ;;; (* 0 -4.0) is -0.0.
 (deftransform - ((x y) ((constant-arg (member 0)) rational) *)
diff --git a/src/compiler/x86-64/arith.lisp b/src/compiler/x86-64/arith.lisp
index f549575..1dbf7b0 100644
--- a/src/compiler/x86-64/arith.lisp
+++ b/src/compiler/x86-64/arith.lisp
@@ -1234,18 +1234,18 @@
 
 ;;;; Modular functions
 
-(define-modular-fun +-mod64 (x y) + 64)
+(define-modular-fun +-mod64 (x y) + :unsigned 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-modular-fun --mod64 (x y) - :unsigned 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-modular-fun *-mod64 (x y) * :unsigned 64)
 (define-vop (fast-*-mod64/unsigned=>unsigned fast-*/unsigned=>unsigned)
   (:translate *-mod64))
 ;;; (no -C variant as x86 MUL instruction doesn't take an immediate)
@@ -1260,7 +1260,7 @@
   (unsigned-byte 64)
   (foldable flushable movable))
 
-(define-modular-fun-optimizer %lea ((base index scale disp) :width width)
+(define-modular-fun-optimizer %lea ((base index scale disp) :unsigned :width width)
   (when (and (<= width 64)
 	     (constant-lvar-p scale)
 	     (constant-lvar-p disp))
@@ -1286,7 +1286,7 @@
   (:translate %lea-mod64))
 
 ;;; logical operations
-(define-modular-fun lognot-mod64 (x) lognot 64)
+(define-modular-fun lognot-mod64 (x) lognot :unsigned 64)
 (define-vop (lognot-mod64/unsigned=>unsigned)
   (:translate lognot-mod64)
   (:args (x :scs (unsigned-reg unsigned-stack) :target r
@@ -1304,7 +1304,7 @@
     (move r x)
     (inst not r)))
 
-(define-modular-fun logxor-mod64 (x y) logxor 64)
+(define-modular-fun logxor-mod64 (x y) logxor :unsigned 64)
 (define-vop (fast-logxor-mod64/unsigned=>unsigned
              fast-logxor/unsigned=>unsigned)
   (:translate logxor-mod64))
diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp
index ade7689..e71a87d 100644
--- a/src/compiler/x86/arith.lisp
+++ b/src/compiler/x86/arith.lisp
@@ -1192,21 +1192,33 @@
 
 ;;;; 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)
+(macrolet ((def (name -c-p)
+             (let ((fun32 (intern (format nil "~S-MOD32" name)))
+                   (vopu (intern (format nil "FAST-~S/UNSIGNED=>UNSIGNED" name)))
+                   (vopcu (intern (format nil "FAST-~S-C/UNSIGNED=>UNSIGNED" name)))
+                   (vopf (intern (format nil "FAST-~S/FIXNUM=>FIXNUM" name)))
+                   (vopcf (intern (format nil "FAST-~S-C/FIXNUM=>FIXNUM" name)))
+                   (vop32u (intern (format nil "FAST-~S-MOD32/UNSIGNED=>UNSIGNED" name)))
+                   (vop32f (intern (format nil "FAST-~S-MOD32/FIXNUM=>FIXNUM" name)))
+                   (vop32cu (intern (format nil "FAST-~S-MOD32-C/UNSIGNED=>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))))
+               `(progn
+                  (define-modular-fun ,fun32 (x y) ,name :unsigned 32)
+                  (define-modular-fun ,sfun30 (x y) ,name :signed 30)
+                  (define-vop (,vop32u ,vopu) (:translate ,fun32))
+                  (define-vop (,vop32f ,vopf) (:translate ,fun32))
+                  (define-vop (,svop30f ,vopf) (:translate ,sfun30))
+                  ,@(when -c-p
+                      `((define-vop (,vop32cu ,vopcu) (:translate ,fun32))
+                        (define-vop (,svop30cf ,vopcf) (:translate ,sfun30))))))))
+  (def + t)
+  (def - t)
+  ;; (no -C variant as x86 MUL instruction doesn't take an immediate)
+  (def * nil))
+
 
 (define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
              fast-ash-c/unsigned=>unsigned)
@@ -1220,39 +1232,74 @@
     (sb!c::give-up-ir1-transform))
   '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
 
+(define-vop (fast-ash-left-smod30-c/fixnum=>fixnum
+             fast-ash-c/fixnum=>fixnum)
+  (:translate ash-left-smod30))
+
+(define-vop (fast-ash-left-smod30/fixnum=>fixnum
+             fast-ash-left/fixnum=>fixnum))
+(deftransform ash-left-smod30 ((integer count)
+                               ((signed-byte 30) (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))
+
 (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)
+  (foldable flushable movable))
 
-(define-modular-fun-optimizer %lea ((base index scale disp) :width width)
+(define-modular-fun-optimizer %lea ((base index scale disp) :unsigned :width width)
   (when (and (<= width 32)
 	     (constant-lvar-p scale)
 	     (constant-lvar-p disp))
-    (cut-to-width base width)
-    (cut-to-width index width)
+    (cut-to-width base :unsigned width)
+    (cut-to-width index :unsigned width)
     'sb!vm::%lea-mod32))
+(define-modular-fun-optimizer %lea ((base index scale disp) :signed :width width)
+  (when (and (<= width 30)
+	     (constant-lvar-p scale)
+	     (constant-lvar-p disp))
+    (cut-to-width base :signed width)
+    (cut-to-width index :signed width)
+    'sb!vm::%lea-smod30))
 
 #+sb-xc-host
-(defun sb!vm::%lea-mod32 (base index scale disp)
-  (ldb (byte 32 0) (%lea base index scale disp)))
+(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))))
 #-sb-xc-host
-(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))))
+(progn
+  (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))))
+  (defun sb!vm::%lea-smod30 (base index scale disp)
+    (let ((base (mask-signed-field 30 base))
+          (index (mask-signed-field 30 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)))))
 
 (in-package "SB!VM")
 
 (define-vop (%lea-mod32/unsigned=>unsigned
 	     %lea/unsigned=>unsigned)
   (:translate %lea-mod32))
+(define-vop (%lea-smod30/fixnum=>fixnum
+	     %lea/fixnum=>fixnum)
+  (:translate %lea-smod30))
 
 ;;; logical operations
-(define-modular-fun lognot-mod32 (x) lognot 32)
+(define-modular-fun lognot-mod32 (x) lognot :unsigned 32)
 (define-vop (lognot-mod32/unsigned=>unsigned)
   (:translate lognot-mod32)
   (:args (x :scs (unsigned-reg unsigned-stack) :target r
@@ -1270,13 +1317,19 @@
     (move r x)
     (inst not r)))
 
-(define-modular-fun logxor-mod32 (x y) logxor 32)
+(define-modular-fun logxor-mod32 (x y) logxor :unsigned 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-vop (fast-logxor-mod32/fixnum=>fixnum
+             fast-logxor/fixnum=>fixnum)
+  (:translate logxor-mod32))
+(define-vop (fast-logxor-mod32-c/fixnum=>fixnum
+             fast-logxor-c/fixnum=>fixnum)
+  (:translate logxor-mod32))
 
 (define-source-transform logeqv (&rest args)
   (if (oddp (length args))
@@ -1599,40 +1652,47 @@
 
 (in-package "SB!C")
 
+(defun mask-result (class width result)
+  (ecase class
+    (:unsigned
+     `(logand ,result ,(1- (ash 1 width))))
+    (:signed
+     `(mask-signed-field ,width ,result))))
+
 ;;; 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 (class width arg num n-bits condensed)
   (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))))
+       (mask-result class width
+                    `(%lea ,arg
+                           ,(decompose-multiplication class width
+                             arg (ash (1- num) (- tmp)) (1- n-bits) (subseq condensed 1))
+                           ,(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))))
+       (mask-result class width
+                    `(%lea ,(decompose-multiplication class width
+                             arg (- num (ash 1 r0)) (1- n-bits) (subseq condensed 1))
+                           ,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))))))
+	 (mask-result class width
+                      `(ash ,(decompose-multiplication class width
+                              arg (ash num (- r0)) n-bits condensed)
+                            ,r0))))))
 
-(defun decompose-multiplication (arg num n-bits condensed)
+(defun decompose-multiplication (class width arg num n-bits condensed)
   (cond
     ((= n-bits 0) 0)
     ((= num 1) arg)
     ((= n-bits 1)
-     `(logand #xffffffff (ash ,arg ,(1- (integer-length num)))))
+     (mask-result class width `(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))
@@ -1648,18 +1708,19 @@
 	   (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))))))))
+	   (mask-result class width
+                        `(- ,(optimize-multiply class width arg n2)
+                            ,(optimize-multiply  class width arg n1))))))))
     ((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))))
-	   
-(defun optimize-multiply (arg x)
+	     (return `(let ((,x ,(optimize-multiply class width arg (/ num i))))
+		       ,(mask-result class width
+                                     `(%lea ,x ,x (1- ,i) 0)))))))))
+    (t (basic-decompose-multiplication class width arg num n-bits condensed))))
+
+(defun optimize-multiply (class width arg x)
   (let* ((n-bits (logcount x))
 	 (condensed (make-array n-bits)))
     (let ((count 0) (bit 0))
@@ -1669,9 +1730,9 @@
 	       (setf count 1)
 	       (incf bit))
 	      (t (incf count)))))
-    (decompose-multiplication arg x n-bits condensed)))
+    (decompose-multiplication class width arg x n-bits condensed)))
 
-(defun *-transformer (y)
+(defun *-transformer (class width y)
   (cond
     ((= y (ash 1 (integer-length y)))
      ;; there's a generic transform for y = 2^k
@@ -1685,21 +1746,33 @@
     ;; 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 class width 'x y))))
 
 (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 :unsigned 32 y)))
 (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 :unsigned 32 y)))
+
+(deftransform * ((x y)
+		 ((signed-byte 30) (constant-arg (unsigned-byte 32)))
+		 (signed-byte 30))
+  "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))
+  "recode as leas, shifts and adds"
+  (let ((y (lvar-value y)))
+    (*-transformer :signed 30 y)))
 
 ;;; 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/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 3bfaf65..ba1eeed 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1656,3 +1656,14 @@
   (dotimes (i 100)
     (when (> (funcall fun t) 9)
       (error "bad RANDOM event"))))
+
+;;; 0.8.17.28-sma.1 lost derived type information.
+(handler-bind ((sb-ext:compiler-note #'error))
+  (compile nil
+    '(lambda (x y v)
+      (declare (optimize (speed 3) (safety 0)))
+      (declare (type (integer 0 80) x)
+       (type (integer 0 11) y)
+       (type (simple-array (unsigned-byte 32) (*)) v))
+      (setf (aref v 0) (* (* x #.(floor (ash 1 32) (* 11 80))) y))
+      nil)))
diff --git a/version.lisp-expr b/version.lisp-expr
index 2c95b47..a880985 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.28"
+"0.8.17.29"