X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=518d88b56f23e51c9ecbcc0851a8342e0c2a56a1;hb=eb6f8dd033501c7372b27967a2cb7750560897bd;hp=f675b2eb1249353087c6b786f05da58294bed065;hpb=6cc71ab8ffad49f43895ad0a1df6885c81876687;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index f675b2e..518d88b 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2346,53 +2346,42 @@
 	      (specifier-type 'unsigned-byte)))
 	*universal-type*)))
 
-(defoptimizer (%dpb derive-type) ((newbyte size posn int))
+(defun %deposit-field-derive-type-aux (size posn int)
   (let ((size (continuation-type size))
 	(posn (continuation-type posn))
 	(int (continuation-type int)))
-    (if (and (numeric-type-p size)
-	     (csubtypep size (specifier-type 'integer))
-	     (numeric-type-p posn)
-	     (csubtypep posn (specifier-type 'integer))
-	     (numeric-type-p int)
-	     (csubtypep int (specifier-type 'integer)))
-	(let ((size-high (numeric-type-high size))
-	      (posn-high (numeric-type-high posn))
-	      (high (numeric-type-high int))
-	      (low (numeric-type-low int)))
-	  (if (and size-high posn-high high low
-		   (<= (+ size-high posn-high) sb!vm:n-word-bits))
-	      (specifier-type
-	       (list (if (minusp low) 'signed-byte 'unsigned-byte)
-		     (max (integer-length high)
-			  (integer-length low)
-			  (+ size-high posn-high))))
-	      *universal-type*))
-	*universal-type*)))
+    (when (and (numeric-type-p size)
+               (numeric-type-p posn)
+               (numeric-type-p int))
+      (let ((size-high (numeric-type-high size))
+            (posn-high (numeric-type-high posn))
+            (high (numeric-type-high int))
+            (low (numeric-type-low int)))
+        (when (and size-high posn-high high low
+		   ;; KLUDGE: we need this cutoff here, otherwise we
+		   ;; will merrily derive the type of %DPB as
+		   ;; (UNSIGNED-BYTE 1073741822), and then attempt to
+		   ;; canonicalize this type to (INTEGER 0 (1- (ASH 1
+		   ;; 1073741822))), with hilarious consequences.  We
+		   ;; cutoff at 4*SB!VM:N-WORD-BITS to allow inference
+		   ;; over a reasonable amount of shifting, even on
+		   ;; the alpha/32 port, where N-WORD-BITS is 32 but
+		   ;; machine integers are 64-bits.  -- CSR,
+		   ;; 2003-09-12
+                   (<= (+ size-high posn-high) (* 4 sb!vm:n-word-bits)))
+          (let ((raw-bit-count (max (integer-length high)
+                                    (integer-length low)
+                                    (+ size-high posn-high))))
+            (specifier-type
+             (if (minusp low)
+                 `(signed-byte ,(1+ raw-bit-count))
+                 `(unsigned-byte ,raw-bit-count)))))))))
+
+(defoptimizer (%dpb derive-type) ((newbyte size posn int))
+  (%deposit-field-derive-type-aux size posn int))
 
 (defoptimizer (%deposit-field derive-type) ((newbyte size posn int))
-  (let ((size (continuation-type size))
-	(posn (continuation-type posn))
-	(int (continuation-type int)))
-    (if (and (numeric-type-p size)
-	     (csubtypep size (specifier-type 'integer))
-	     (numeric-type-p posn)
-	     (csubtypep posn (specifier-type 'integer))
-	     (numeric-type-p int)
-	     (csubtypep int (specifier-type 'integer)))
-	(let ((size-high (numeric-type-high size))
-	      (posn-high (numeric-type-high posn))
-	      (high (numeric-type-high int))
-	      (low (numeric-type-low int)))
-	  (if (and size-high posn-high high low
-		   (<= (+ size-high posn-high) sb!vm:n-word-bits))
-	      (specifier-type
-	       (list (if (minusp low) 'signed-byte 'unsigned-byte)
-		     (max (integer-length high)
-			  (integer-length low)
-			  (+ size-high posn-high))))
-	      *universal-type*))
-	*universal-type*)))
+  (%deposit-field-derive-type-aux size posn int))
 
 (deftransform %ldb ((size posn int)
 		    (fixnum fixnum integer)