diff --git a/compiler/generic/vm-tran.lisp b/compiler/generic/vm-tran.lisp index cab9b020ba741beafe5a1d42a469329f52b81999..8b81723eb7fd31ab896a886733b138c1d55820f7 100644 --- a/compiler/generic/vm-tran.lisp +++ b/compiler/generic/vm-tran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.55 2004/09/08 02:10:55 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.56 2004/10/04 20:27:06 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -379,6 +379,46 @@ (setf (%raw-bits result-bit-array index) (32bit-logical-not (%raw-bits bit-array index)))))))) +(deftransform count ((item sequence) (bit simple-bit-vector) * + :policy (>= speed space)) + `(let ((length (length sequence))) + (if (zerop length) + 0 + (do ((index vm:vector-data-offset (1+ index)) + (count 0) + (end-1 (+ vm:vector-data-offset + (truncate (truly-the index (1- length)) + vm:word-bits)))) + ((= index end-1) + (let* ((extra (mod length vm:word-bits)) + (mask (1- (ash 1 extra))) + (bits (logand (ash mask + ,(ecase (c:backend-byte-order c:*target-backend*) + (:little-endian 0) + (:big-endian + '(- vm:word-bits extra)))) + (%raw-bits sequence index)))) + (declare (type (mod #.vm:word-bits) extra)) + (declare (type (unsigned-byte #.vm:word-bits) mask bits)) + ;; could consider LOGNOT for the zero case instead of + ;; doing the subtraction... + (incf count ,(if (constant-continuation-p item) + (if (zerop (continuation-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-continuation-p item) + (if (zerop (continuation-value item)) + '(- vm:word-bits (logcount (%raw-bits sequence index))) + '(logcount (%raw-bits sequence index))) + '(if (zerop item) + (- vm:word-bits (logcount (%raw-bits sequence index))) + (logcount (%raw-bits sequence index))))))))) + ;;;; Primitive translator for byte-blt