0.8.3.54:

[sbcl.git] / src / compiler / srctran.lisp

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 150cb3a..e2cb897 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -179,8 +179,14 @@
 (define-source-transform logorc1 (x y) `(logior (lognot ,x) ,y))
 (define-source-transform logorc2 (x y) `(logior ,x (lognot ,y)))
 (define-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
-(define-source-transform logbitp (index integer)
-  `(not (zerop (logand (ash 1 ,index) ,integer))))
+
+(deftransform logbitp
+    ((index integer) (unsigned-byte (or (signed-byte #.sb!vm:n-word-bits)
+                                       (unsigned-byte #.sb!vm:n-word-bits))))
+  `(if (>= index #.sb!vm:n-word-bits)
+       (minusp integer)
+       (not (zerop (logand integer (ash 1 index))))))
+
 (define-source-transform byte (size position)
   `(cons ,size ,position))
 (define-source-transform byte-size (spec) `(car ,spec))
@@ -992,10 +998,13 @@
         (member (first members))
         (member-type (type-of member)))
     (aver (not (rest members)))
-    (specifier-type `(,(if (subtypep member-type 'integer)
-                          'integer
-                          member-type)
-                     ,member ,member))))
+    (specifier-type (cond ((typep member 'integer)
+                           `(integer ,member ,member))
+                          ((memq member-type '(short-float single-float
+                                               double-float long-float))
+                           `(,member-type ,member ,member))
+                          (t
+                           member-type)))))
 
 ;;; This is used in defoptimizers for computing the resulting type of
 ;;; a function.
@@ -2337,53 +2346,32 @@
              (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
+                   (<= (+ size-high posn-high) 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)
@@ -2772,7 +2760,19 @@
     ;; multiplication and division for small integral powers.
     (unless (not-more-contagious y x)
       (give-up-ir1-transform))
-    (cond ((zerop val) '(float 1 x))
+    (cond ((zerop val)
+           (let ((x-type (continuation-type x)))
+             (cond ((csubtypep x-type (specifier-type '(or rational
+                                                        (complex rational))))
+                    '1)
+                   ((csubtypep x-type (specifier-type 'real))
+                    `(if (rationalp x)
+                         1
+                         (float 1 x)))
+                   ((csubtypep x-type (specifier-type 'complex))
+                    ;; both parts are float
+                    `(1+ (* x ,val)))
+                   (t (give-up-ir1-transform)))))
          ((= val 2) '(* x x))
          ((= val -2) '(/ (* x x)))
          ((= val 3) '(* x x x))