0.8.19.32:

[sbcl.git] / src / compiler / generic / vm-tran.lisp

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index e47aec5..7866594 100644 (file)
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -317,7 +317,7 @@
                    (end-1 (+ sb!vm:vector-data-offset
                              (floor (1- length) sb!vm:n-word-bits))))
                   ((= i end-1)
-                   (let* ((extra (mod length sb!vm:n-word-bits))
+                   (let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits)))
                           (mask (1- (ash 1 extra)))
                           (numx
                            (logand
@@ -335,8 +335,7 @@
                                     (:big-endian
                                      '(- sb!vm:n-word-bits extra))))
                             (%raw-bits y i))))
-                     (declare (type (mod #.sb!vm:n-word-bits)
-                                     extra)
+                     (declare (type (integer 1 #.sb!vm:n-word-bits) extra)
                               (type sb!vm:word mask numx numy))
                      (= numx numy)))
                (declare (type index i end-1))
@@ -357,7 +356,7 @@
                        (truncate (truly-the index (1- length))
                                  sb!vm:n-word-bits))))
             ((= index end-1)
-             (let* ((extra (mod length sb!vm:n-word-bits))
+             (let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits)))
                    (mask (1- (ash 1 extra)))
                    (bits (logand (ash mask
                                       ,(ecase sb!c:*backend-byte-order*
@@ -365,7 +364,7 @@
                                               (:big-endian
                                                '(- sb!vm:n-word-bits extra))))
                                  (%raw-bits sequence index))))
-               (declare (type (mod #.sb!vm:n-word-bits) extra))
+               (declare (type (integer 1 #.sb!vm:n-word-bits) extra))
                (declare (type sb!vm:word mask bits))
                ;; could consider LOGNOT for the zero case instead of
                ;; doing the subtraction...
@@ -488,32 +487,39 @@
 
 \f
 ;;;; 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))
+  (progn
+    #!+x86-64 (def sb!vm::ash-left-smod61 :signed 61)
+    (def sb!vm::ash-left-mod64 :unsigned 64)))
 
 \f
 ;;;; word-wise logical operations