0.8.13.25:

	* add new COUNT transform on bitvectors; add tests for same
	* begin to use SB!VM:WORD instead of (UNSIGNED-BYTE foo) where
	  appropriate

diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp
index 69b835a..f5b74b3 100644 (file)
--- a/src/compiler/generic/vm-fndb.lisp
+++ b/src/compiler/generic/vm-fndb.lisp
@@ -98,7 +98,7 @@
 (defknown %layout-invalid-error (t layout) nil)
 
 
-(sb!xc:deftype raw-vector () '(simple-array (unsigned-byte 32) (*)))
+(sb!xc:deftype raw-vector () '(simple-array sb!vm:word (*)))
 
 (defknown %raw-ref-single (raw-vector index) single-float
   (foldable flushable))
@@ -128,9 +128,9 @@
   (unsafe))
 
 
-(defknown %raw-bits (t fixnum) (unsigned-byte 32)
+(defknown %raw-bits (t fixnum) sb!vm:word
   (foldable flushable))
-(defknown (%set-raw-bits) (t fixnum (unsigned-byte 32)) (unsigned-byte 32)
+(defknown (%set-raw-bits) (t fixnum sb!vm:word) sb!vm:word
   (unsafe))
 
 
@@ -164,17 +164,17 @@
 (defknown %set-stack-ref (system-area-pointer index t) t (unsafe))
 (defknown lra-code-header (t) t (movable flushable))
 (defknown fun-code-header (t) t (movable flushable))
-(defknown make-lisp-obj ((unsigned-byte 32)) t (movable flushable))
-(defknown get-lisp-obj-address (t) (unsigned-byte 32) (movable flushable))
+(defknown make-lisp-obj (sb!vm:word) t (movable flushable))
+(defknown get-lisp-obj-address (t) sb!vm:word (movable flushable))
 (defknown fun-word-offset (function) index (movable flushable))
 \f
 ;;;; 32-bit logical operations
 
-(defknown merge-bits ((unsigned-byte 5) (unsigned-byte 32) (unsigned-byte 32))
-  (unsigned-byte 32)
+(defknown merge-bits ((unsigned-byte 5) sb!vm:word sb!vm:word)
+  sb!vm:word
   (foldable flushable movable))
 
-(defknown 32bit-logical-not ((unsigned-byte 32)) (unsigned-byte 32)
+(defknown 32bit-logical-not (sb!vm:word) sb!vm:word
   (foldable flushable movable))
 
 (defknown (32bit-logical-and 32bit-logical-nand
@@ -182,11 +182,11 @@
           32bit-logical-xor 32bit-logical-eqv
           32bit-logical-andc1 32bit-logical-andc2
           32bit-logical-orc1 32bit-logical-orc2)
-         ((unsigned-byte 32) (unsigned-byte 32)) (unsigned-byte 32)
+         (sb!vm:word sb!vm:word) sb!vm:word
   (foldable flushable movable))
 
-(defknown (shift-towards-start shift-towards-end) ((unsigned-byte 32) fixnum)
-  (unsigned-byte 32)
+(defknown (shift-towards-start shift-towards-end) (sb!vm:word fixnum)
+  sb!vm:word
   (foldable flushable movable))
 \f
 ;;;; bignum operations

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index baf07fc..461138e 100644 (file)
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -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)

diff --git a/tests/bit-vector.impure-cload.lisp b/tests/bit-vector.impure-cload.lisp
index 640470b..137d19d 100644 (file)
--- a/tests/bit-vector.impure-cload.lisp
+++ b/tests/bit-vector.impure-cload.lisp
@@ -39,7 +39,24 @@
     (assert (= (aref a (- array-dimension-limit 2)) 1))
     (bit-and a b a)
     (assert (= (aref a 0) 0))
-    (assert (= (aref a (- array-dimension-limit 2)) 0))))
+    (assert (= (aref a (- array-dimension-limit 2)) 0)))
+  ;; a special COUNT transform on bitvectors; triggers on (>= SPEED SPACE)
+  (locally
+   (declare (optimize (speed 3) (space 1)))
+   (let ((bv1 (make-array 5 :element-type 'bit))
+        (bv2 (make-array 0 :element-type 'bit))
+        (bv3 (make-array 68 :element-type 'bit)))
+     (declare (type simple-bit-vector bv1 bv2 bv3))
+     (setf (sbit bv3 42) 1)
+     ;; bitvector smaller than the word size
+     (assert (= 0 (count 1 bv1)))
+     (assert (= 5 (count 0 bv1)))
+     ;; special case of 0-length bitvectors
+     (assert (= 0 (count 1 bv2)))
+     (assert (= 0 (count 0 bv2)))
+     ;; bitvector larger than the word size
+     (assert (= 1 (count 1 bv3)))
+     (assert (= 67 (count 0 bv3))))))
 
 (bit-vector-test)
 \f

diff --git a/version.lisp-expr b/version.lisp-expr
index 34d5b6d..b61054c 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.13.24"
+"0.8.13.25"