diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index 014489fd091ae8a63947cb5cca00758c488a19cb..1edbfdae4f3d8dde4b55bbaf5dd6813e8131d286 100644
--- a/compiler/srctran.lisp
+++ b/compiler/srctran.lisp
@@ -260,16 +260,35 @@
 			    nil))))))))
 
 (defoptimizer (ash derive-type) ((n shift))
-  (let ((type (continuation-type n)))
-    (if (and (numeric-type-p type)
-	     (constant-continuation-p shift))
-	(let ((low (numeric-type-low type))
-	      (high (numeric-type-high type))
-	      (shift (continuation-value shift)))
-	  (make-numeric-type :class 'integer  :complexp :real
-			     :low (when low (ash low shift))
-			     :high (when high (ash high shift))))
-	*universal-type*)))
+  (or (let ((n-type (continuation-type n)))
+	(when (numeric-type-p n-type)
+	  (let ((n-low (numeric-type-low n-type))
+		(n-high (numeric-type-high n-type)))
+	    (if (constant-continuation-p shift)
+		(let ((shift (continuation-value shift)))
+		  (make-numeric-type :class 'integer  :complexp :real
+				     :low (when n-low (ash n-low shift))
+				     :high (when n-high (ash n-high shift))))
+		(let ((s-type (continuation-type shift)))
+		  (format *trace-output* "~&n-type: ~S~%s-type: ~S~%"
+			  n-type s-type)
+		  (when (numeric-type-p s-type)
+		    (let ((s-low (numeric-type-low s-type))
+			  (s-high (numeric-type-high s-type)))
+		      (let ((new-type
+	     (if (and s-low s-high (<= s-low 32) (<= s-high 32))
+		 (make-numeric-type :class 'integer  :complexp :real
+				    :low (when n-low
+					   (min (ash n-low s-high)
+						(ash n-low s-low)))
+				    :high (when n-high
+					    (max (ash n-high s-high)
+						 (ash n-high s-low))))
+		 (make-numeric-type :class 'integer
+				    :complexp :real))))
+			(format *trace-output* "new-type: ~S~2%" new-type)
+			new-type))))))))
+      *universal-type*))
 
 
 ;;; Negative-Integer-P  --  Internal
@@ -452,10 +471,25 @@
       (give-up))
     (values size pos)))
 
-(deftransform %ldb ((size pos int) (t t fixnum))
-  (multiple-value-bind (size pos)
-		       (check-fixnum-byte size pos)
-    `(logand (ash int ,(- pos)) ,(ldb (byte size 0) -1))))
+(defun max-value (cont)
+  (if (constant-continuation-p cont)
+      (continuation-value cont)
+      (let ((type (continuation-type cont)))
+	(or (and (numeric-type-p type)
+		 (numeric-type-high type))
+	    (give-up
+	     "Size is not constant and its upper bound is not known.")))))
+
+(deftransform %ldb ((size pos int) (fixnum fixnum integer))
+  (let ((size-len (max-value size)))
+    (unless (<= size-len (integer-length most-positive-fixnum))
+      (format *trace-output* "~&max-size=~D~%" size-len)
+      (give-up "result might be up to ~D bits, can't open code %ldb." size-len))
+    (if (zerop size-len)
+	0
+	`(logand (ash int (- pos))
+		 (ash ,(1- (ash 1 (integer-length most-positive-fixnum)))
+		      (- size ,(integer-length most-positive-fixnum)))))))
 
 (deftransform %dpb ((new size pos int) (t t t fixnum))
   (multiple-value-bind (size pos)
@@ -532,6 +566,69 @@
 	`(- (ash x ,len))
 	`(ash x ,len))))
 
+;;; If arg is a constant power of two, turn floor into a shift and mask.
+;;; 
+(deftransform floor ((x y) (integer integer))
+  (unless (constant-continuation-p y) (give-up))
+  (let* ((y (continuation-value y))
+	 (y-abs (abs y))
+	 (len (1- (integer-length y-abs))))
+    (unless (= y-abs (ash 1 len)) (give-up))
+    (let ((shift (- len))
+	  (mask (1- y-abs)))
+      (if (minusp y)
+	  `(values (ash (- x) ,shift)
+		   (- (logand (- x) ,mask)))
+	  `(values (ash x ,shift)
+		   (logand x ,mask))))))
+
+;;; Do the same for mod.
+;;;
+(deftransform mod ((x y) (integer integer))
+  (unless (constant-continuation-p y) (give-up))
+  (let* ((y (continuation-value y))
+	 (y-abs (abs y))
+	 (len (1- (integer-length y-abs))))
+    (unless (= y-abs (ash 1 len)) (give-up))
+    (let ((mask (1- y-abs)))
+      (if (minusp y)
+	  `(- (logand (- x) ,mask))
+	  `(logand x ,mask)))))
+
+
+;;; If arg is a constant power of two, turn truncate into a shift and mask.
+;;;
+(deftransform truncate ((x y) (integer integer))
+  (unless (constant-continuation-p y) (give-up))
+  (let* ((y (continuation-value y))
+	 (y-abs (abs y))
+	 (len (1- (integer-length y-abs))))
+    (unless (= y-abs (ash 1 len)) (give-up))
+    (let* ((shift (- len))
+	   (mask (1- y-abs)))
+      `(if (minusp x)
+	   (values ,(if (minusp y)
+			`(ash (- x) ,shift)
+			`(- (ash (- x) ,shift)))
+		   (- (logand (- x) ,mask)))
+	   (values ,(if (minusp y)
+			`(- (ash (- x) ,shift))
+			`(ash x ,shift))
+		   (logand x ,mask))))))
+
+;;; And the same for rem.
+;;;
+(deftransform rem ((x y) (integer integer))
+  (unless (constant-continuation-p y) (give-up))
+  (let* ((y (continuation-value y))
+	 (y-abs (abs y))
+	 (len (1- (integer-length y-abs))))
+    (unless (= y-abs (ash 1 len)) (give-up))
+    (let ((mask (1- y-abs)))
+      `(if (minusp x)
+	   (- (logand (- x) ,mask))
+	   (logand x ,mask)))))
+
 
 ;;;; Character operations: