\f
;;;; types
-(deftype bit-offset () '(integer 0 (#.sb!vm:n-word-bits)))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (deftype bit-offset () '(integer 0 (#.sb!vm:n-word-bits))))
;;;; support routines
;;; these, or DEFTRANSFORMs to convert them into something supported
;;; by the architecture.
(macrolet ((def (name &rest args)
- `(defun ,name ,args
- (,name ,@args))))
+ `(defun ,name ,args
+ (,name ,@args))))
(def word-logical-not x)
(def word-logical-and x y)
(def word-logical-or x y)
;;; at the "end" and removing bits from the "start". On big-endian
;;; machines this is a left-shift and on little-endian machines this
;;; is a right-shift.
-(defun shift-towards-start (number countoid)
- (declare (type sb!vm:word number) (fixnum countoid))
- (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) countoid)))
- (declare (type bit-offset count))
- (if (zerop count)
- number
- (ecase sb!c:*backend-byte-order*
- (:big-endian
- (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count))
- (:little-endian
- (ash number (- count)))))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun shift-towards-start (number countoid)
+ (declare (type sb!vm:word number) (fixnum countoid))
+ (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) countoid)))
+ (declare (type bit-offset count))
+ (if (zerop count)
+ number
+ (ecase sb!c:*backend-byte-order*
+ (:big-endian
+ (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count))
+ (:little-endian
+ (ash number (- count))))))))
;;; Shift NUMBER by COUNT bits, adding zero bits at the "start" and
;;; removing bits from the "end". On big-endian machines this is a
;;; right-shift and on little-endian machines this is a left-shift.
-(defun shift-towards-end (number count)
- (declare (type sb!vm:word number) (fixnum count))
- (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) count)))
- (declare (type bit-offset count))
- (if (zerop count)
- number
- (ecase sb!c:*backend-byte-order*
- (:big-endian
- (ash number (- count)))
- (:little-endian
- (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count))))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun shift-towards-end (number count)
+ (declare (type sb!vm:word number) (fixnum count))
+ (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) count)))
+ (declare (type bit-offset count))
+ (if (zerop count)
+ number
+ (ecase sb!c:*backend-byte-order*
+ (:big-endian
+ (ash number (- count)))
+ (:little-endian
+ (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count)))))))
#!-sb-fluid (declaim (inline start-mask end-mask))
#!-sb-fluid (declaim (inline word-sap-ref %set-word-sap-ref))
(defun word-sap-ref (sap offset)
(declare (type system-area-pointer sap)
- (type index offset)
- (values sb!vm:word)
- (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3)))
- (sap-ref-word sap (the index (ash offset sb!vm:n-fixnum-tag-bits))))
+ (type index offset)
+ (values sb!vm:word)
+ (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3)))
+ (sap-ref-word sap (the index (ash offset sb!vm:word-shift))))
(defun %set-word-sap-ref (sap offset value)
(declare (type system-area-pointer sap)
- (type index offset)
- (type sb!vm:word value)
- (values sb!vm:word)
- (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
- (setf (sap-ref-word sap (the index (ash offset sb!vm:n-fixnum-tag-bits)))
- value))
+ (type index offset)
+ (type sb!vm:word value)
+ (values sb!vm:word)
+ (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
+ (setf (sap-ref-word sap (the index (ash offset sb!vm:word-shift)))
+ value))
\f
;;; the actual bashers and common uses of same
;;; Align the SAP to a word boundary, and update the offset accordingly.
(defmacro !define-sap-fixer (bitsize)
- (let ((name (intern (format nil "FIX-SAP-AND-OFFSET-UB~A" bitsize))))
+ (let ((name (intern (format nil "FIX-SAP-AND-OFFSET-UB~D" bitsize))))
`(progn
(declaim (inline ,name))
(defun ,name (sap offset)
(declare (type system-area-pointer sap)
(type index offset)
(values system-area-pointer index))
- (let ((address (sap-int sap)))
- (values (int-sap #!-alpha (word-logical-andc2 address
- sb!vm:fixnum-tag-mask)
- #!+alpha (ash (ash address -2) 2))
+ (let ((address (sap-int sap))
+ (word-mask (1- (ash 1 word-shift))))
+ (values (int-sap #!-alpha (word-logical-andc2 address word-mask)
+ ;; KLUDGE: WORD-LOGICAL-ANDC2 is defined in
+ ;; terms of n-word-bits. On all systems
+ ;; where n-word-bits is not equal to
+ ;; n-machine-word-bits we have to do this
+ ;; another way. At this time, these
+ ;; systems are alphas, though there was
+ ;; some talk about an x86-64 build option.
+ #!+alpha (ash (ash address (- word-shift)) word-shift))
(+ ,(ecase bitsize
- (1 '(* (logand address sb!vm:fixnum-tag-mask) n-byte-bits))
- (2 '(* (logand address sb!vm:fixnum-tag-mask) (/ n-byte-bits 2)))
- (4 '(* (logand address sb!vm:fixnum-tag-mask) (/ n-byte-bits 4)))
- ((8 16 32 64) '(logand address sb!vm:fixnum-tag-mask)))
+ ((1 2 4) `(* (logand address word-mask)
+ (/ n-byte-bits ,bitsize)))
+ ((8 16 32 64) '(logand address word-mask)))
offset)))))))
+;;; We cheat a little bit by using TRULY-THE in the copying function to
+;;; force the compiler to generate good code in the (= BITSIZE
+;;; SB!VM:N-WORD-BITS) case. We don't use TRULY-THE in the other cases
+;;; to give the compiler freedom to generate better code.
(defmacro !define-byte-bashers (bitsize)
(let* ((bytes-per-word (/ n-word-bits bitsize))
(byte-offset `(integer 0 (,bytes-per-word)))
(byte-count `(integer 1 (,bytes-per-word)))
- (max-bytes (ash most-positive-fixnum
+ (max-bytes (ash sb!xc:most-positive-fixnum
;; FIXME: this reflects code contained in the
;; original bit-bash.lisp, but seems very
;; nonsensical. Why shouldn't we be able to
(4 0)
(8 0)
(16 0)
- (32 0))))
+ (32 0)
+ (64 0))))
(offset `(integer 0 ,max-bytes))
(max-word-offset (ceiling max-bytes bytes-per-word))
(word-offset `(integer 0 ,max-word-offset))
- (fix-sap-and-offset-name (intern (format nil "FIX-SAP-AND-OFFSET-UB~A" bitsize)))
- (constant-bash-name (intern (format nil "CONSTANT-UB~A-BASH" bitsize) (find-package "SB!KERNEL")))
- (array-fill-name (intern (format nil "UB~A-BASH-FILL" bitsize) (find-package "SB!KERNEL")))
- (system-area-fill-name (intern (format nil "SYSTEM-AREA-UB~A-FILL" bitsize) (find-package "SB!KERNEL")))
- (unary-bash-name (intern (format nil "UNARY-UB~A-BASH" bitsize) (find-package "SB!KERNEL")))
- (array-copy-name (intern (format nil "UB~A-BASH-COPY" bitsize) (find-package "SB!KERNEL")))
- (system-area-copy-name (intern (format nil "SYSTEM-AREA-UB~A-COPY" bitsize) (find-package "SB!KERNEL")))
+ (fix-sap-and-offset-name (intern (format nil "FIX-SAP-AND-OFFSET-UB~D" bitsize)))
+ (constant-bash-name (intern (format nil "CONSTANT-UB~D-BASH" bitsize) (find-package "SB!KERNEL")))
+ (array-fill-name (intern (format nil "UB~D-BASH-FILL" bitsize) (find-package "SB!KERNEL")))
+ (system-area-fill-name (intern (format nil "SYSTEM-AREA-UB~D-FILL" bitsize) (find-package "SB!KERNEL")))
+ (unary-bash-name (intern (format nil "UNARY-UB~D-BASH" bitsize) (find-package "SB!KERNEL")))
+ (array-copy-name (intern (format nil "UB~D-BASH-COPY" bitsize) (find-package "SB!KERNEL")))
+ (system-area-copy-name (intern (format nil "SYSTEM-AREA-UB~D-COPY" bitsize) (find-package "SB!KERNEL")))
(array-copy-to-system-area-name
- (intern (format nil "COPY-UB~A-TO-SYSTEM-AREA" bitsize) (find-package "SB!KERNEL")))
+ (intern (format nil "COPY-UB~D-TO-SYSTEM-AREA" bitsize) (find-package "SB!KERNEL")))
(system-area-copy-to-array-name
- (intern (format nil "COPY-UB~A-FROM-SYSTEM-AREA" bitsize)
+ (intern (format nil "COPY-UB~D-FROM-SYSTEM-AREA" bitsize)
(find-package "SB!KERNEL"))))
`(progn
(declaim (inline ,constant-bash-name ,unary-bash-name))
(word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset)
mask))))
(incf dst-word-offset))))
+ (let ((end (+ dst-word-offset interior)))
+ (declare (type ,word-offset end))
+ (do ()
+ ((>= dst-word-offset end))
+ (funcall dst-set-fn dst dst-word-offset value)
+ (incf dst-word-offset)))
+ #+nil
(dotimes (i interior)
(funcall dst-set-fn dst dst-word-offset value)
(incf dst-word-offset))
(values))
;; common uses for constant-byte-bashing
+ (defknown ,array-fill-name (word simple-unboxed-array ,offset ,offset)
+ simple-unboxed-array
+ ()
+ :result-arg 1)
(defun ,array-fill-name (value dst dst-offset length)
(declare (type word value) (type ,offset dst-offset length))
(declare (optimize (speed 3) (safety 1)))
(,constant-bash-name dst dst-offset length value
- #'%vector-raw-bits #'%set-vector-raw-bits))
+ #'%vector-raw-bits #'%set-vector-raw-bits)
+ dst)
(defun ,system-area-fill-name (value dst dst-offset length)
(declare (type word value) (type ,offset dst-offset length))
(declare (optimize (speed 3) (safety 1)))
(incf src-word-offset)
(incf dst-word-offset))))
;; Copy the interior words.
- (dotimes (i interior)
- (funcall dst-set-fn dst dst-word-offset (funcall src-ref-fn src src-word-offset))
- (incf src-word-offset)
- (incf dst-word-offset))
+ (let ((end ,(if (= bytes-per-word 1)
+ `(truly-the ,word-offset
+ (+ dst-word-offset interior))
+ `(+ dst-word-offset interior))))
+ (declare (type ,word-offset end))
+ (do ()
+ ((>= dst-word-offset end))
+ (funcall dst-set-fn dst dst-word-offset
+ (funcall src-ref-fn src src-word-offset))
+ ,(if (= bytes-per-word 1)
+ `(setf src-word-offset (truly-the ,word-offset (+ src-word-offset 1)))
+ `(incf src-word-offset))
+ (incf dst-word-offset)))
,@(unless (= bytes-per-word 1)
`((unless (zerop final-bytes)
;; We are only writing part of the last word.
(word-logical-andc2 orig mask))))))))
(t
;; We need to loop from right to left.
- (incf dst-word-offset words)
- (incf src-word-offset words)
+ ,(if (= bytes-per-word 1)
+ `(setf dst-word-offset (truly-the ,word-offset
+ (+ dst-word-offset words)))
+ `(incf dst-word-offset words))
+ ,(if (= bytes-per-word 1)
+ `(setf src-word-offset (truly-the ,word-offset
+ (+ src-word-offset words)))
+ `(incf src-word-offset words))
,@(unless (= bytes-per-word 1)
`((unless (zerop final-bytes)
(let ((mask (start-mask (* final-bytes ,bitsize)))
(funcall dst-set-fn dst dst-word-offset
(word-logical-or (word-logical-and value mask)
(word-logical-andc2 orig mask)))))))
- (dotimes (i interior)
- (decf src-word-offset)
- (decf dst-word-offset)
- (funcall dst-set-fn dst dst-word-offset (funcall src-ref-fn src src-word-offset)))
+ (let ((end (- dst-word-offset interior)))
+ (do ()
+ ((<= dst-word-offset end))
+ (decf src-word-offset)
+ (decf dst-word-offset)
+ (funcall dst-set-fn dst dst-word-offset
+ (funcall src-ref-fn src src-word-offset))))
,@(unless (= bytes-per-word 1)
`((unless (zerop dst-byte-offset)
;; We are only writing part of the last word.
(declare (type word prev next))
(flet ((get-next-src ()
(setf prev next)
- (setf next (funcall src-ref-fn src (incf src-word-offset)))))
+ (setf next (funcall src-ref-fn src
+ (incf src-word-offset)))))
(declare (inline get-next-src))
,@(unless (= bytes-per-word 1)
`((unless (zerop dst-byte-offset)
(word-logical-or (word-logical-and value mask)
(word-logical-andc2 orig mask))))
(incf dst-word-offset))))
- (dotimes (i interior)
- (get-next-src)
- (let ((value (word-logical-or
- (shift-towards-end next (* (- src-shift) ,bitsize))
- (shift-towards-start prev (* src-shift ,bitsize)))))
- (declare (type word value))
- (funcall dst-set-fn dst dst-word-offset value)
- (incf dst-word-offset)))
+ (let ((end (+ dst-word-offset interior)))
+ (declare (type ,word-offset end))
+ (do ()
+ ((>= dst-word-offset end))
+ (get-next-src)
+ (let ((value (word-logical-or
+ (shift-towards-end next (* (- src-shift) ,bitsize))
+ (shift-towards-start prev (* src-shift ,bitsize)))))
+ (declare (type word value))
+ (funcall dst-set-fn dst dst-word-offset value)
+ (incf dst-word-offset))))
,@(unless (= bytes-per-word 1)
`((unless (zerop final-bytes)
(let ((value
(t
;; We need to loop from right to left.
(incf dst-word-offset words)
- (incf src-word-offset
- (1- (ceiling (+ src-byte-offset length) ,bytes-per-word)))
+ (incf src-word-offset (1- (ceiling (+ src-byte-offset length) ,bytes-per-word)))
(let ((next 0)
(prev (funcall src-ref-fn src src-word-offset)))
(declare (type word prev next))
(word-logical-or (word-logical-and value mask)
(word-logical-andc2 orig mask)))))))
(decf dst-word-offset)
- (dotimes (i interior)
- (get-next-src)
- (let ((value (word-logical-or
- (shift-towards-end next (* (- src-shift) ,bitsize))
- (shift-towards-start prev (* src-shift ,bitsize)))))
- (declare (type word value))
- (funcall dst-set-fn dst dst-word-offset value)
- (decf dst-word-offset)))
+ (let ((end (- dst-word-offset interior)))
+ (do ()
+ ((<= dst-word-offset end))
+ (get-next-src)
+ (let ((value (word-logical-or
+ (shift-towards-end next (* (- src-shift) ,bitsize))
+ (shift-towards-start prev (* src-shift ,bitsize)))))
+ (declare (type word value))
+ (funcall dst-set-fn dst dst-word-offset value)
+ (decf dst-word-offset))))
,@(unless (= bytes-per-word 1)
`((unless (zerop dst-byte-offset)
(if (> src-byte-offset dst-byte-offset)
(declare (type system-area-pointer sap))
(declare (type fixnum offset))
(copy-ub8-to-system-area bv 0 sap offset (length bv)))
+
+\f
+;;;; Bashing-Style search for bits
+;;;;
+;;;; Similar search would work well for base-strings as well.
+;;;; (Technically for all unboxed sequences of sub-word size elements,
+;;;; but somehow I doubt eg. octet vectors get POSITION or FIND used
+;;;; as much on them.)
+(defconstant +bit-position-base-mask+ (1- n-word-bits))
+(defconstant +bit-position-base-shift+ (integer-length +bit-position-base-mask+))
+(macrolet ((def (name frob)
+ `(defun ,name (vector from-end start end)
+ (declare (simple-bit-vector vector)
+ (index start end)
+ (optimize (speed 3) (safety 0)))
+ (unless (= start end)
+ (let* ((last-word (ash end (- +bit-position-base-shift+)))
+ (last-bits (logand end +bit-position-base-mask+))
+ (first-word (ash start (- +bit-position-base-shift+)))
+ (first-bits (logand start +bit-position-base-mask+))
+ ;; These mask out everything but the interesting parts.
+ (end-mask #!+little-endian (lognot (ash -1 last-bits))
+ #!+big-endian (ash -1 (- sb!vm:n-word-bits last-bits)))
+ (start-mask #!+little-endian (ash -1 first-bits)
+ #!+big-endian (lognot (ash -1 (- sb!vm:n-word-bits first-bits)))))
+ (declare (index last-word first-word))
+ (flet ((#!+little-endian start-bit
+ #!+big-endian end-bit (x)
+ (declare (word x))
+ (- #!+big-endian sb!vm:n-word-bits
+ (integer-length (logand x (- x)))
+ #!+little-endian 1))
+ (#!+little-endian end-bit
+ #!+big-endian start-bit (x)
+ (declare (word x))
+ (- #!+big-endian sb!vm:n-word-bits
+ (integer-length x)
+ #!+little-endian 1))
+ (found (i word-offset)
+ (declare (index i word-offset))
+ (return-from ,name
+ (logior i (truly-the
+ fixnum
+ (ash word-offset +bit-position-base-shift+)))))
+ (get-word (offset)
+ (,@frob (%vector-raw-bits vector offset))))
+ (declare (inline start-bit end-bit get-word))
+ (if from-end
+ ;; Back to front
+ (let* ((word-offset last-word)
+ (word (logand end-mask (get-word word-offset))))
+ (declare (word word)
+ (index word-offset))
+ (unless (zerop word)
+ (when (= word-offset first-word)
+ (setf word (logand word start-mask)))
+ (unless (zerop word)
+ (found (end-bit word) word-offset)))
+ (decf word-offset)
+ (loop
+ (when (< word-offset first-word)
+ (return-from ,name nil))
+ (setf word (get-word word-offset))
+ (unless (zerop word)
+ (when (= word-offset first-word)
+ (setf word (logand word start-mask)))
+ (unless (zerop word)
+ (found (end-bit word) word-offset)))
+ (decf word-offset)))
+ ;; Front to back
+ (let* ((word-offset first-word)
+ (word (logand start-mask (get-word word-offset))))
+ (declare (word word)
+ (index word-offset))
+ (unless (zerop word)
+ (when (= word-offset last-word)
+ (setf word (logand word end-mask)))
+ (unless (zerop word)
+ (found (start-bit word) word-offset)))
+ (incf word-offset)
+ (loop
+ (when (> word-offset last-word)
+ (return-from ,name nil))
+ (setf word (get-word word-offset))
+ (unless (zerop word)
+ (when (= word-offset last-word)
+ (setf word (logand word end-mask)))
+ (unless (zerop word)
+ (found (start-bit word) word-offset)))
+ (incf word-offset))))))))))
+ (def %bit-position/0 (logandc2 #.(1- (expt 2 n-word-bits))))
+ (def %bit-position/1 (identity)))
+(defun %bit-position (bit vector from-end start end)
+ (case bit
+ (0 (%bit-position/0 vector from-end start end))
+ (1 (%bit-position/1 vector from-end start end))
+ (otherwise nil)))
projects / sbcl.git / blobdiff