From b9a60d8c091096ce7f90073de9b3d26ec7433387 Mon Sep 17 00:00:00 2001 From: Nathan Froyd Date: Wed, 4 Aug 2004 15:55:04 +0000 Subject: [PATCH] 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 --- src/compiler/generic/vm-fndb.lisp | 22 +++++++++--------- src/compiler/generic/vm-tran.lisp | 43 ++++++++++++++++++++++++++++++++++-- tests/bit-vector.impure-cload.lisp | 19 +++++++++++++++- version.lisp-expr | 2 +- 4 files changed, 71 insertions(+), 15 deletions(-) diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index 69b835a..f5b74b3 100644 --- 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)) ;;;; 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)) ;;;; bignum operations diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index baf07fc..461138e 100644 --- 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 --- 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) diff --git a/version.lisp-expr b/version.lisp-expr index 34d5b6d..b61054c 100644 --- 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" -- 1.7.10.4