\f
;;;; constants and types
-(defconstant unit-bits sb!vm:word-bits
- #!+sb-doc
- "The number of bits to process at a time.")
+;;; the number of bits to process at a time
+(defconstant unit-bits n-word-bits)
-(defconstant max-bits (ash most-positive-fixnum -2)
- #!+sb-doc
- "The maximum number of bits that can be delt with during a single call.")
-
-;;; FIXME: Do we really need EVAL-WHEN around these DEFTYPEs?
-(eval-when (:compile-toplevel :load-toplevel :execute)
+;;; the maximum number of bits that can be dealt with in a single call
+(defconstant max-bits (ash sb!xc:most-positive-fixnum -2))
(deftype unit ()
`(unsigned-byte ,unit-bits))
(deftype word-offset ()
`(integer 0 (,(ceiling max-bits unit-bits))))
-
-) ; EVAL-WHEN
\f
;;;; support routines
;;; A particular implementation must offer either VOPs to translate
;;; these, or DEFTRANSFORMs to convert them into something supported
;;; by the architecture.
-(macrolet ((def-frob (name &rest args)
+(macrolet ((def (name &rest args)
`(defun ,name ,args
(,name ,@args))))
- (def-frob 32bit-logical-not x)
- (def-frob 32bit-logical-and x y)
- (def-frob 32bit-logical-or x y)
- (def-frob 32bit-logical-xor x y)
- (def-frob 32bit-logical-nor x y)
- (def-frob 32bit-logical-eqv x y)
- (def-frob 32bit-logical-nand x y)
- (def-frob 32bit-logical-andc1 x y)
- (def-frob 32bit-logical-andc2 x y)
- (def-frob 32bit-logical-orc1 x y)
- (def-frob 32bit-logical-orc2 x y))
+ (def word-logical-not x)
+ (def word-logical-and x y)
+ (def word-logical-or x y)
+ (def word-logical-xor x y)
+ (def word-logical-nor x y)
+ (def word-logical-eqv x y)
+ (def word-logical-nand x y)
+ (def word-logical-andc1 x y)
+ (def word-logical-andc2 x y)
+ (def word-logical-orc1 x y)
+ (def word-logical-orc2 x y))
+;;; Shift NUMBER by the low-order bits of COUNTOID, adding zero bits
+;;; 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)
- #!+sb-doc
- "Shift NUMBER by the low-order bits of COUNTOID, adding zero bits 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."
(declare (type unit number) (fixnum countoid))
(let ((count (ldb (byte (1- (integer-length unit-bits)) 0) countoid)))
(declare (type bit-offset 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)
- #!+sb-doc
- "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."
(declare (type unit number) (fixnum count))
(let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count)))
(declare (type bit-offset count))
(ash (ldb (byte (- unit-bits count) 0) number) count))))))
#!-sb-fluid (declaim (inline start-mask end-mask fix-sap-and-offset))
+
+;;; Produce a mask that contains 1's for the COUNT "start" bits and
+;;; 0's for the remaining "end" bits. Only the lower 5 bits of COUNT
+;;; are significant (KLUDGE: because of hardwired implicit dependence
+;;; on 32-bit word size -- WHN 2001-03-19).
(defun start-mask (count)
- #!+sb-doc
- "Produce a mask that contains 1's for the COUNT ``start'' bits and 0's for
- the remaining ``end'' bits. Only the lower 5 bits of COUNT are significant."
(declare (fixnum count))
(shift-towards-start (1- (ash 1 unit-bits)) (- count)))
+;;; Produce a mask that contains 1's for the COUNT "end" bits and 0's
+;;; for the remaining "start" bits. Only the lower 5 bits of COUNT are
+;;; significant (KLUDGE: because of hardwired implicit dependence on
+;;; 32-bit word size -- WHN 2001-03-19).
(defun end-mask (count)
- #!+sb-doc
- "Produce a mask that contains 1's for the COUNT ``end'' bits and 0's for
- the remaining ``start'' bits. Only the lower 5 bits of COUNT are
- significant."
(declare (fixnum count))
(shift-towards-end (1- (ash 1 unit-bits)) (- count)))
+;;; Align the SAP to a word boundary, and update the offset accordingly.
(defun fix-sap-and-offset (sap offset)
- #!+sb-doc
- "Align the SAP to a word boundary, and update the offset accordingly."
(declare (type system-area-pointer sap)
(type index offset)
(values system-area-pointer index))
(let ((address (sap-int sap)))
- (values (int-sap #!-alpha (32bit-logical-andc2 address 3)
+ (values (int-sap #!-alpha (word-logical-andc2 address 3)
#!+alpha (ash (ash address -2) 2))
- (+ (* (logand address 3) byte-bits) offset))))
+ (+ (* (logand address 3) n-byte-bits) offset))))
#!-sb-fluid (declaim (inline word-sap-ref %set-word-sap-ref))
(defun word-sap-ref (sap offset)
(optimize (speed 3) (safety 0) (inhibit-warnings 3)))
(setf (sap-ref-32 sap (the index (ash offset 2))) value))
\f
-;;;; DO-CONSTANT-BIT-BASH
+;;;; CONSTANT-BIT-BASH
-#!-sb-fluid (declaim (inline do-constant-bit-bash))
-(defun do-constant-bit-bash (dst dst-offset length value dst-ref-fn dst-set-fn)
- #!+sb-doc
- "Fill DST with VALUE starting at DST-OFFSET and continuing for LENGTH bits."
+;;; Fill DST with VALUE starting at DST-OFFSET and continuing for
+;;; LENGTH bits.
+#!-sb-fluid (declaim (inline constant-bit-bash))
+(defun constant-bit-bash (dst dst-offset length value dst-ref-fn dst-set-fn)
(declare (type offset dst-offset) (type unit value)
(type function dst-ref-fn dst-set-fn))
(multiple-value-bind (dst-word-offset dst-bit-offset)
(let ((mask (shift-towards-end (start-mask length)
dst-bit-offset)))
(declare (type unit mask))
- (32bit-logical-or
- (32bit-logical-and value mask)
- (32bit-logical-andc2
+ (word-logical-or
+ (word-logical-and value mask)
+ (word-logical-andc2
(funcall dst-ref-fn dst dst-word-offset)
mask))))))
(let ((interior (floor (- length final-bits) unit-bits)))
(let ((mask (end-mask (- dst-bit-offset))))
(declare (type unit mask))
(funcall dst-set-fn dst dst-word-offset
- (32bit-logical-or
- (32bit-logical-and value mask)
- (32bit-logical-andc2
+ (word-logical-or
+ (word-logical-and value mask)
+ (word-logical-andc2
(funcall dst-ref-fn dst dst-word-offset)
mask))))
(incf dst-word-offset))
(let ((mask (start-mask final-bits)))
(declare (type unit mask))
(funcall dst-set-fn dst dst-word-offset
- (32bit-logical-or
- (32bit-logical-and value mask)
- (32bit-logical-andc2
+ (word-logical-or
+ (word-logical-and value mask)
+ (word-logical-andc2
(funcall dst-ref-fn dst dst-word-offset)
mask)))))))))
(values))
\f
-;;;; DO-UNARY-BIT-BASH
+;;;; UNARY-BIT-BASH
-#!-sb-fluid (declaim (inline do-unary-bit-bash))
-(defun do-unary-bit-bash (src src-offset dst dst-offset length
- dst-ref-fn dst-set-fn src-ref-fn)
+#!-sb-fluid (declaim (inline unary-bit-bash))
+(defun unary-bit-bash (src src-offset dst dst-offset length
+ dst-ref-fn dst-set-fn src-ref-fn)
+ ;; FIXME: Declaring these bit indices to be of type OFFSET, then
+ ;; using the inline expansion in SPEED 3 SAFETY 0 functions, is not
+ ;; a good thing. At the very least, we should make sure that the
+ ;; type (overflow) checks get done. Better would be to avoid
+ ;; using bit indices, and to use 32-bit unsigneds instead, and/or
+ ;; to call out to things like memmove(3) for big moves.
(declare (type offset src-offset dst-offset length)
(type function dst-ref-fn dst-set-fn src-ref-fn))
(multiple-value-bind (dst-word-offset dst-bit-offset)
(type bit-offset src-bit-offset))
(cond
((<= (+ dst-bit-offset length) unit-bits)
- ;; We are only writing one word, so it doesn't matter what order
- ;; we do it in. But we might be reading from multiple words, so take
- ;; care.
+ ;; We are only writing one word, so it doesn't matter what
+ ;; order we do it in. But we might be reading from multiple
+ ;; words, so take care.
(cond
((zerop length)
;; Actually, we aren't even writing one word. This is really easy.
)
((= length unit-bits)
- ;; DST-BIT-OFFSET must be equal to zero, or we would be writing
- ;; multiple words. If SRC-BIT-OFFSET is also zero, then we
- ;; just transfer the single word. Otherwise we have to extract bits
- ;; from two src words.
+ ;; DST-BIT-OFFSET must be equal to zero, or we would be
+ ;; writing multiple words. If SRC-BIT-OFFSET is also zero,
+ ;; then we just transfer the single word. Otherwise we have
+ ;; to extract bits from two src words.
(funcall dst-set-fn dst dst-word-offset
(if (zerop src-bit-offset)
(funcall src-ref-fn src src-word-offset)
- (32bit-logical-or
+ (word-logical-or
(shift-towards-start
(funcall src-ref-fn src src-word-offset)
src-bit-offset)
(funcall src-ref-fn src (1+ src-word-offset))
(- src-bit-offset))))))
(t
- ;; We are only writing some portion of the dst word, so we need to
- ;; preserve the extra bits. Also, we still don't know whether we need
- ;; one or two source words.
+ ;; We are only writing some portion of the dst word, so we
+ ;; need to preserve the extra bits. Also, we still don't
+ ;; know whether we need one or two source words.
(let ((mask (shift-towards-end (start-mask length) dst-bit-offset))
(orig (funcall dst-ref-fn dst dst-word-offset))
(value
(if (> src-bit-offset dst-bit-offset)
- ;; The source starts further into the word than does
- ;; the dst, so the source could extend into the next
- ;; word. If it does, we have to merge the two words,
- ;; and if not, we can just shift the first word.
+ ;; The source starts further into the word than
+ ;; does the dst, so the source could extend into
+ ;; the next word. If it does, we have to merge
+ ;; the two words, and if not, we can just shift
+ ;; the first word.
(let ((src-bit-shift (- src-bit-offset dst-bit-offset)))
(if (> (+ src-bit-offset length) unit-bits)
- (32bit-logical-or
+ (word-logical-or
(shift-towards-start
(funcall src-ref-fn src src-word-offset)
src-bit-shift)
(shift-towards-start
(funcall src-ref-fn src src-word-offset)
src-bit-shift)))
- ;; The dst starts further into the word than does the
- ;; source, so we know the source can not extend into
- ;; a second word (or else the dst would too, and we
- ;; wouldn't be in this branch.
+ ;; The dst starts further into the word than does
+ ;; the source, so we know the source can not
+ ;; extend into a second word (or else the dst
+ ;; would too, and we wouldn't be in this branch.
(shift-towards-end
(funcall src-ref-fn src src-word-offset)
(- dst-bit-offset src-bit-offset)))))
(declare (type unit mask orig value))
;; Replace the dst word.
(funcall dst-set-fn dst dst-word-offset
- (32bit-logical-or
- (32bit-logical-and value mask)
- (32bit-logical-andc2 orig mask)))))))
+ (word-logical-or
+ (word-logical-and value mask)
+ (word-logical-andc2 orig mask)))))))
((= src-bit-offset dst-bit-offset)
;; The source and dst are aligned, so we don't need to shift
- ;; anything. But we have to pick the direction of the loop
- ;; in case the source and dst are really the same thing.
+ ;; anything. But we have to pick the direction of the loop in
+ ;; case the source and dst are really the same thing.
(multiple-value-bind (words final-bits)
(floor (+ dst-bit-offset length) unit-bits)
(declare (type word-offset words) (type bit-offset final-bits))
((<= dst-offset src-offset)
;; We need to loop from left to right
(unless (zerop dst-bit-offset)
- ;; We are only writing part of the first word, so mask off the
- ;; bits we want to preserve.
+ ;; We are only writing part of the first word, so mask
+ ;; off the bits we want to preserve.
(let ((mask (end-mask (- dst-bit-offset)))
(orig (funcall dst-ref-fn dst dst-word-offset))
(value (funcall src-ref-fn src src-word-offset)))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
- (32bit-logical-or (32bit-logical-and value mask)
- (32bit-logical-andc2 orig mask))))
+ (word-logical-or (word-logical-and value mask)
+ (word-logical-andc2 orig mask))))
(incf src-word-offset)
(incf dst-word-offset))
;; Just copy the interior words.
(value (funcall src-ref-fn src src-word-offset)))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
- (32bit-logical-or
- (32bit-logical-and value mask)
- (32bit-logical-andc2 orig mask))))))
+ (word-logical-or
+ (word-logical-and value mask)
+ (word-logical-andc2 orig mask))))))
(t
;; We need to loop from right to left.
(incf dst-word-offset words)
(value (funcall src-ref-fn src src-word-offset)))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
- (32bit-logical-or
- (32bit-logical-and value mask)
- (32bit-logical-andc2 orig mask)))))
+ (word-logical-or
+ (word-logical-and value mask)
+ (word-logical-andc2 orig mask)))))
(dotimes (i interior)
(decf src-word-offset)
(decf dst-word-offset)
(value (funcall src-ref-fn src src-word-offset)))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
- (32bit-logical-or
- (32bit-logical-and value mask)
- (32bit-logical-andc2 orig mask))))))))))
+ (word-logical-or
+ (word-logical-and value mask)
+ (word-logical-andc2 orig mask))))))))))
(t
;; They aren't aligned.
(multiple-value-bind (words final-bits)
(get-next-src))
(let ((mask (end-mask (- dst-bit-offset)))
(orig (funcall dst-ref-fn dst dst-word-offset))
- (value (32bit-logical-or
+ (value (word-logical-or
(shift-towards-start prev src-shift)
(shift-towards-end next (- src-shift)))))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
- (32bit-logical-or
- (32bit-logical-and value mask)
- (32bit-logical-andc2 orig mask)))
+ (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 (32bit-logical-or
+ (let ((value (word-logical-or
(shift-towards-end next (- src-shift))
(shift-towards-start prev src-shift))))
(declare (type unit value))
(if (> (+ final-bits src-shift) unit-bits)
(progn
(get-next-src)
- (32bit-logical-or
+ (word-logical-or
(shift-towards-end next (- src-shift))
(shift-towards-start prev src-shift)))
(shift-towards-start next src-shift)))
(orig (funcall dst-ref-fn dst dst-word-offset)))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
- (32bit-logical-or
- (32bit-logical-and value mask)
- (32bit-logical-andc2 orig mask))))))))
+ (word-logical-or
+ (word-logical-and value mask)
+ (word-logical-andc2 orig mask))))))))
(t
;; We need to loop from right to left.
(incf dst-word-offset words)
(unless (zerop final-bits)
(when (> final-bits (- unit-bits src-shift))
(get-next-src))
- (let ((value (32bit-logical-or
+ (let ((value (word-logical-or
(shift-towards-end next (- src-shift))
(shift-towards-start prev src-shift)))
(mask (start-mask final-bits))
(orig (funcall dst-ref-fn dst dst-word-offset)))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
- (32bit-logical-or
- (32bit-logical-and value mask)
- (32bit-logical-andc2 orig mask)))))
+ (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 (32bit-logical-or
+ (let ((value (word-logical-or
(shift-towards-end next (- src-shift))
(shift-towards-start prev src-shift))))
(declare (type unit value))
(setf next prev prev 0))
(let ((mask (end-mask (- dst-bit-offset)))
(orig (funcall dst-ref-fn dst dst-word-offset))
- (value (32bit-logical-or
+ (value (word-logical-or
(shift-towards-start prev src-shift)
(shift-towards-end next (- src-shift)))))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
- (32bit-logical-or
- (32bit-logical-and value mask)
- (32bit-logical-andc2 orig mask)))))))))))))))
+ (word-logical-or
+ (word-logical-and value mask)
+ (word-logical-andc2 orig mask)))))))))))))))
(values))
\f
;;;; the actual bashers
(declare (type unit value) (type offset dst-offset length))
(locally
(declare (optimize (speed 3) (safety 0)))
- (do-constant-bit-bash dst dst-offset length value
- #'%raw-bits #'%set-raw-bits)))
+ (constant-bit-bash dst dst-offset length value
+ #'%raw-bits #'%set-raw-bits)))
(defun system-area-fill (value dst dst-offset length)
(declare (type unit value) (type offset dst-offset length))
(locally
(declare (optimize (speed 3) (safety 0)))
(multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
- (do-constant-bit-bash dst dst-offset length value
- #'word-sap-ref #'%set-word-sap-ref))))
+ (constant-bit-bash dst dst-offset length value
+ #'word-sap-ref #'%set-word-sap-ref))))
(defun bit-bash-copy (src src-offset dst dst-offset length)
(declare (type offset src-offset dst-offset length))
(locally
(declare (optimize (speed 3) (safety 0))
- (inline do-unary-bit-bash))
- (do-unary-bit-bash src src-offset dst dst-offset length
- #'%raw-bits #'%set-raw-bits #'%raw-bits)))
+ (inline unary-bit-bash))
+ (unary-bit-bash src src-offset dst dst-offset length
+ #'%raw-bits #'%set-raw-bits #'%raw-bits)))
(defun system-area-copy (src src-offset dst dst-offset length)
(declare (type offset src-offset dst-offset length))
(declare (type system-area-pointer src))
(multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
(declare (type system-area-pointer dst))
- (do-unary-bit-bash src src-offset dst dst-offset length
- #'word-sap-ref #'%set-word-sap-ref
- #'word-sap-ref)))))
+ (unary-bit-bash src src-offset dst dst-offset length
+ #'word-sap-ref #'%set-word-sap-ref
+ #'word-sap-ref)))))
(defun copy-to-system-area (src src-offset dst dst-offset length)
(declare (type offset src-offset dst-offset length))
(locally
(declare (optimize (speed 3) (safety 0)))
(multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
- (do-unary-bit-bash src src-offset dst dst-offset length
- #'word-sap-ref #'%set-word-sap-ref #'%raw-bits))))
+ (unary-bit-bash src src-offset dst dst-offset length
+ #'word-sap-ref #'%set-word-sap-ref #'%raw-bits))))
(defun copy-from-system-area (src src-offset dst dst-offset length)
(declare (type offset src-offset dst-offset length))
(locally
(declare (optimize (speed 3) (safety 0)))
(multiple-value-bind (src src-offset) (fix-sap-and-offset src src-offset)
- (do-unary-bit-bash src src-offset dst dst-offset length
- #'%raw-bits #'%set-raw-bits #'word-sap-ref))))
+ (unary-bit-bash src src-offset dst dst-offset length
+ #'%raw-bits #'%set-raw-bits #'word-sap-ref))))
;;; a common idiom for calling COPY-TO-SYSTEM-AREA
;;;
(defun copy-byte-vector-to-system-area (bv sap &optional (offset 0))
;; FIXME: There should be a type like SB!VM:BYTE so that we can write this
;; type as (SIMPLE-ARRAY SB!VM:BYTE 1). Except BYTE is an external symbol of
- ;; package CL; so maybe SB!VM:VM-BYTE?
+ ;; package CL, and shadowing it would be too ugly; so maybe SB!VM:VMBYTE?
+ ;; (And then N-BYTE-BITS would be N-VMBYTE-BITS and so forth?)
(declare (type (simple-array (unsigned-byte 8) 1) bv))
- (declare (type sap sap))
+ (declare (type system-area-pointer sap))
(declare (type fixnum offset))
- ;; FIXME: Actually it looks as though this, and most other calls
- ;; to COPY-TO-SYSTEM-AREA, could be written more concisely with BYTE-BLT.
- ;; Except that the DST-END-DST-START convention for the length is confusing.
- ;; Perhaps I could rename BYTE-BLT to BYTE-BLIT and replace the
- ;; DST-END argument with an N-BYTES argument?
+ ;; FIXME: Actually it looks as though this, and most other calls to
+ ;; COPY-TO-SYSTEM-AREA, could be written more concisely with
+ ;; %BYTE-BLT. Except that the DST-END-DST-START convention for the
+ ;; length is confusing. Perhaps I could rename %BYTE-BLT to
+ ;; %BYTE-BLIT (and correspondingly rename the corresponding VOP) and
+ ;; replace the DST-END argument with an N-BYTES argument?
(copy-to-system-area bv
- (* sb!vm:vector-data-offset sb!vm:word-bits)
+ (* vector-data-offset n-word-bits)
sap
offset
- (* (length bv) sb!vm:byte-bits)))
+ (* (length bv) n-byte-bits)))
projects / sbcl.git / blobdiff