X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fbit-bash.lisp;h=23f58ec475954e5e310040590ff3eb7e104de3e9;hb=9767de1cecfe50560fe1da69fd458b6148a66da3;hp=64cd3441fd8fbe2a1f2ac4f54f5974c8a7018eb7;hpb=adf0d51d2bde8b723276bacf94641df9aa5ae561;p=sbcl.git diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp index 64cd344..23f58ec 100644 --- a/src/code/bit-bash.lisp +++ b/src/code/bit-bash.lisp @@ -10,21 +10,14 @@ ;;;; files for more information. (in-package "SB!VM") - -(file-comment - "$Header$") ;;;; constants and types -(eval-when (:compile-toplevel :load-toplevel :execute) - -(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.") +;;; 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)) @@ -40,35 +33,32 @@ (deftype word-offset () `(integer 0 (,(ceiling max-bits unit-bits)))) - -) ; EVAL-WHEN ;;;; 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 32bit-logical-not x) + (def 32bit-logical-and x y) + (def 32bit-logical-or x y) + (def 32bit-logical-xor x y) + (def 32bit-logical-nor x y) + (def 32bit-logical-eqv x y) + (def 32bit-logical-nand x y) + (def 32bit-logical-andc1 x y) + (def 32bit-logical-andc2 x y) + (def 32bit-logical-orc1 x y) + (def 32bit-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)) @@ -80,11 +70,10 @@ (: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)) @@ -97,31 +86,32 @@ (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) #!+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) @@ -138,12 +128,12 @@ (optimize (speed 3) (safety 0) (inhibit-warnings 3))) (setf (sap-ref-32 sap (the index (ash offset 2))) value)) -;;;; 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) @@ -191,11 +181,17 @@ mask))))))))) (values)) -;;;; 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) @@ -208,18 +204,18 @@ (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) @@ -231,17 +227,18 @@ (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 @@ -254,10 +251,10 @@ (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))))) @@ -269,8 +266,8 @@ (32bit-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)) @@ -280,8 +277,8 @@ ((<= 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))) @@ -451,24 +448,24 @@ (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)) @@ -478,25 +475,25 @@ (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 ;;; @@ -504,17 +501,19 @@ (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)))