0.8.13.26:

[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 baf07fc..29c5c06 100644 (file)
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -258,16 +258,16 @@
                          (setf (%raw-bits result-bit-array index)
                                (,',wordfun (%raw-bits bit-array-1 index)
                                            (%raw-bits bit-array-2 index))))))))))
- (def bit-and 32bit-logical-and)
- (def bit-ior 32bit-logical-or)
- (def bit-xor 32bit-logical-xor)
- (def bit-eqv 32bit-logical-eqv)
- (def bit-nand 32bit-logical-nand)
- (def bit-nor 32bit-logical-nor)
- (def bit-andc1 32bit-logical-andc1)
- (def bit-andc2 32bit-logical-andc2)
- (def bit-orc1 32bit-logical-orc1)
- (def bit-orc2 32bit-logical-orc2))
+ (def bit-and word-logical-and)
+ (def bit-ior word-logical-or)
+ (def bit-xor word-logical-xor)
+ (def bit-eqv word-logical-eqv)
+ (def bit-nand word-logical-nand)
+ (def bit-nor word-logical-nor)
+ (def bit-andc1 word-logical-andc1)
+ (def bit-andc2 word-logical-andc2)
+ (def bit-orc1 word-logical-orc1)
+ (def bit-orc2 word-logical-orc2))
 
 (deftransform bit-not
              ((bit-array result-bit-array)
@@ -296,12 +296,12 @@
                                   sb!vm:n-word-bits))))
              ((= index end-1)
               (setf (%raw-bits result-bit-array index)
-                    (32bit-logical-not (%raw-bits bit-array index)))
+                    (word-logical-not (%raw-bits bit-array index)))
               result-bit-array)
            (declare (optimize (speed 3) (safety 0))
                     (type index index end-1))
            (setf (%raw-bits result-bit-array index)
-                 (32bit-logical-not (%raw-bits bit-array index))))))))
+                 (word-logical-not (%raw-bits bit-array index))))))))
 
 (deftransform bit-vector-= ((x y) (simple-bit-vector simple-bit-vector))
   `(and (= (length x) (length y))
@@ -330,15 +330,54 @@
                                      '(- sb!vm:n-word-bits extra))))
                             (%raw-bits y i))))
                      (declare (type (integer 0 31) extra)
-                              (type (unsigned-byte 32) mask numx numy))
+                              (type sb!vm:word mask numx numy))
                      (= numx numy)))
                (declare (type index i end-1))
                (let ((numx (%raw-bits x i))
                      (numy (%raw-bits y i)))
-                 (declare (type (unsigned-byte 32) numx numy))
+                 (declare (type sb!vm:word numx numy))
                  (unless (= numx numy)
                    (return nil))))))))
 
+(deftransform count ((sequence item) (simple-bit-vector bit) *
+                     :policy (>= speed space))
+  `(let ((length (length sequence)))
+    (if (zerop length)
+        0
+        (do ((index sb!vm:vector-data-offset (1+ index))
+             (count 0)
+             (end-1 (+ sb!vm:vector-data-offset
+                       (truncate (truly-the index (1- length))
+                                 sb!vm:n-word-bits))))
+            ((= index end-1)
+             (let* ((extra (mod length sb!vm:n-word-bits))
+                   (mask (1- (ash 1 extra)))
+                   (bits (logand (ash mask
+                                      ,(ecase sb!c:*backend-byte-order*
+                                              (:little-endian 0)
+                                              (:big-endian
+                                               '(- sb!vm:n-word-bits extra))))
+                                 (%raw-bits sequence index))))
+               (declare (type sb!vm:word mask bits))
+               ;; could consider LOGNOT for the zero case instead of
+               ;; doing the subtraction...
+               (incf count ,(if (constant-lvar-p item)
+                                (if (zerop (lvar-value item))
+                                    '(- extra (logcount bits))
+                                    '(logcount bits))
+                                '(if (zerop item)
+                                     (- extra (logcount bits))
+                                     (logcount bits))))))
+          (declare (type index index count end-1)
+                  (optimize (speed 3) (safety 0)))
+          (incf count ,(if (constant-lvar-p item)
+                           (if (zerop (lvar-value item))
+                               '(- sb!vm:n-word-bits (logcount (%raw-bits sequence index)))
+                               '(logcount (%raw-bits sequence index)))
+                           '(if (zerop item)
+                             (- sb!vm:n-word-bits (logcount (%raw-bits sequence index)))
+                             (logcount (%raw-bits sequence index)))))))))
+
 (deftransform fill ((sequence item) (simple-bit-vector bit) *
                    :policy (>= speed space))
   (let ((value (if (constant-lvar-p item)