X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fbit-bash.lisp;h=c2fb216ae517c8bd94b957cc26bb863fc0d14869;hb=338732358d49ab202fe55c3581294597d63aec6b;hp=64cd3441fd8fbe2a1f2ac4f54f5974c8a7018eb7;hpb=adf0d51d2bde8b723276bacf94641df9aa5ae561;p=sbcl.git diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp index 64cd344..c2fb216 100644 --- a/src/code/bit-bash.lisp +++ b/src/code/bit-bash.lisp @@ -10,83 +10,53 @@ ;;;; 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.") - -(defconstant max-bits (ash most-positive-fixnum -2) - #!+sb-doc - "The maximum number of bits that can be delt with during a single call.") - -(deftype unit () - `(unsigned-byte ,unit-bits)) +;;;; types -(deftype offset () - `(integer 0 ,max-bits)) +(deftype bit-offset () '(integer 0 (#.sb!vm:n-word-bits))) -(deftype bit-offset () - `(integer 0 (,unit-bits))) - -(deftype bit-count () - `(integer 1 (,unit-bits))) - -(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 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 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 (- unit-bits count) 0) number) count)) + (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) - #!+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 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 @@ -94,427 +64,484 @@ (:big-endian (ash number (- count))) (:little-endian - (ash (ldb (byte (- unit-bits count) 0) number) count)))))) + (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count)))))) -#!-sb-fluid (declaim (inline start-mask end-mask fix-sap-and-offset)) +#!-sb-fluid (declaim (inline start-mask end-mask)) + +;;; 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))) + (shift-towards-start (1- (ash 1 sb!vm:n-word-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))) - -(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)))) + (shift-towards-end (1- (ash 1 sb!vm:n-word-bits)) (- count))) #!-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 (unsigned-byte 32)) + (values sb!vm:word) (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3))) - (sap-ref-32 sap (the index (ash offset 2)))) + (sap-ref-word sap (the index (ash offset sb!vm:n-fixnum-tag-bits)))) (defun %set-word-sap-ref (sap offset value) (declare (type system-area-pointer sap) (type index offset) - (type (unsigned-byte 32) value) - (values (unsigned-byte 32)) + (type sb!vm:word value) + (values sb!vm:word) (optimize (speed 3) (safety 0) (inhibit-warnings 3))) - (setf (sap-ref-32 sap (the index (ash offset 2))) value)) - -;;;; DO-CONSTANT-BIT-BASH + (setf (sap-ref-word sap (the index (ash offset sb!vm:n-fixnum-tag-bits))) + value)) -#!-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." - (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) - (floor dst-offset unit-bits) - (declare (type word-offset dst-word-offset) - (type bit-offset dst-bit-offset)) - (multiple-value-bind (words final-bits) - (floor (+ dst-bit-offset length) unit-bits) - (declare (type word-offset words) (type bit-offset final-bits)) - (if (zerop words) - (unless (zerop length) - (funcall dst-set-fn dst dst-word-offset - (if (= length unit-bits) - value - (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 - (funcall dst-ref-fn dst dst-word-offset) - mask)))))) - (let ((interior (floor (- length final-bits) unit-bits))) - (unless (zerop dst-bit-offset) - (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 - (funcall dst-ref-fn dst dst-word-offset) - mask)))) - (incf dst-word-offset)) - (dotimes (i interior) - (funcall dst-set-fn dst dst-word-offset value) - (incf dst-word-offset)) - (unless (zerop final-bits) - (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 - (funcall dst-ref-fn dst dst-word-offset) - mask))))))))) - (values)) -;;;; DO-UNARY-BIT-BASH +;;; the actual bashers and common uses of same -#!-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) - (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) - (floor dst-offset unit-bits) - (declare (type word-offset dst-word-offset) - (type bit-offset dst-bit-offset)) - (multiple-value-bind (src-word-offset src-bit-offset) - (floor src-offset unit-bits) - (declare (type word-offset src-word-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. - (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. - (funcall dst-set-fn dst dst-word-offset - (if (zerop src-bit-offset) - (funcall src-ref-fn src src-word-offset) - (32bit-logical-or - (shift-towards-start - (funcall src-ref-fn src src-word-offset) - src-bit-offset) - (shift-towards-end - (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. - (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. - (let ((src-bit-shift (- src-bit-offset dst-bit-offset))) - (if (> (+ src-bit-offset length) unit-bits) - (32bit-logical-or - (shift-towards-start - (funcall src-ref-fn src src-word-offset) - src-bit-shift) - (shift-towards-end - (funcall src-ref-fn src (1+ 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. - (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))))))) - ((= 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. - (multiple-value-bind (words final-bits) - (floor (+ dst-bit-offset length) unit-bits) - (declare (type word-offset words) (type bit-offset final-bits)) - (let ((interior (floor (- length final-bits) unit-bits))) - (declare (type word-offset interior)) - (cond - ((<= 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. - (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)))) - (incf src-word-offset) - (incf dst-word-offset)) - ;; Just 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)) - (unless (zerop final-bits) - ;; We are only writing part of the last word. - (let ((mask (start-mask final-bits)) - (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)))))) - (t - ;; We need to loop from right to left. - (incf dst-word-offset words) - (incf src-word-offset words) - (unless (zerop final-bits) - (let ((mask (start-mask final-bits)) - (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))))) - (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))) - (unless (zerop dst-bit-offset) - (decf src-word-offset) - (decf dst-word-offset) - (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)))))))))) - (t - ;; They aren't aligned. - (multiple-value-bind (words final-bits) - (floor (+ dst-bit-offset length) unit-bits) - (declare (type word-offset words) (type bit-offset final-bits)) - (let ((src-shift (mod (- src-bit-offset dst-bit-offset) unit-bits)) - (interior (floor (- length final-bits) unit-bits))) - (declare (type bit-offset src-shift) - (type word-offset interior)) - (cond - ((<= dst-offset src-offset) - ;; We need to loop from left to right - (let ((prev 0) - (next (funcall src-ref-fn src src-word-offset))) - (declare (type unit prev next)) - (flet ((get-next-src () - (setf prev next) - (setf next (funcall src-ref-fn src - (incf src-word-offset))))) - (declare (inline get-next-src)) - (unless (zerop dst-bit-offset) - (when (> src-bit-offset dst-bit-offset) - (get-next-src)) - (let ((mask (end-mask (- dst-bit-offset))) - (orig (funcall dst-ref-fn dst dst-word-offset)) - (value (32bit-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))) - (incf dst-word-offset))) - (dotimes (i interior) - (get-next-src) - (let ((value (32bit-logical-or - (shift-towards-end next (- src-shift)) - (shift-towards-start prev src-shift)))) - (declare (type unit value)) - (funcall dst-set-fn dst dst-word-offset value) - (incf dst-word-offset))) - (unless (zerop final-bits) - (let ((value - (if (> (+ final-bits src-shift) unit-bits) - (progn - (get-next-src) - (32bit-logical-or - (shift-towards-end next (- src-shift)) - (shift-towards-start prev src-shift))) - (shift-towards-start next 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)))))))) - (t - ;; We need to loop from right to left. - (incf dst-word-offset words) - (incf src-word-offset - (1- (ceiling (+ src-bit-offset length) unit-bits))) - (let ((next 0) - (prev (funcall src-ref-fn src src-word-offset))) - (declare (type unit prev next)) - (flet ((get-next-src () - (setf next prev) - (setf prev (funcall src-ref-fn src - (decf src-word-offset))))) - (declare (inline get-next-src)) - (unless (zerop final-bits) - (when (> final-bits (- unit-bits src-shift)) - (get-next-src)) - (let ((value (32bit-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))))) - (decf dst-word-offset) - (dotimes (i interior) - (get-next-src) - (let ((value (32bit-logical-or - (shift-towards-end next (- src-shift)) - (shift-towards-start prev src-shift)))) - (declare (type unit value)) - (funcall dst-set-fn dst dst-word-offset value) - (decf dst-word-offset))) - (unless (zerop dst-bit-offset) - (if (> src-bit-offset dst-bit-offset) - (get-next-src) - (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 - (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))))))))))))))) - (values)) - -;;;; the actual bashers +;;; This is a little ugly. Fixing bug 188 would bring the ability to +;;; wrap a MACROLET or something similar around this whole thing would +;;; make things significantly less ugly. --njf, 2005-02-23 +(eval-when (:compile-toplevel :load-toplevel :execute) + +;;; 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)))) + `(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)) + (+ ,(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))) + offset))))))) -(defun bit-bash-fill (value dst dst-offset length) - (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))) +(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 + ;; FIXME: this reflects code contained in the + ;; original bit-bash.lisp, but seems very + ;; nonsensical. Why shouldn't we be able to + ;; handle M-P-FIXNUM bits? And if we can't, + ;; are these other shift amounts bogus, too? + (ecase bitsize + (1 -2) + (2 -1) + (4 0) + (8 0) + (16 0) + (32 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"))) + (array-copy-to-system-area-name + (intern (format nil "COPY-UB~A-TO-SYSTEM-AREA" bitsize) (find-package "SB!KERNEL"))) + (system-area-copy-to-array-name + (intern (format nil "COPY-UB~A-FROM-SYSTEM-AREA" bitsize) + (find-package "SB!KERNEL")))) + `(progn + (declaim (inline ,constant-bash-name ,unary-bash-name)) + ;; Fill DST with VALUE starting at DST-OFFSET and continuing + ;; for LENGTH bytes (however bytes are defined). + (defun ,constant-bash-name (dst dst-offset length value + dst-ref-fn dst-set-fn) + (declare (type word value) (type index dst-offset length)) + (declare (ignorable dst-ref-fn)) + (multiple-value-bind (dst-word-offset dst-byte-offset) + (floor dst-offset ,bytes-per-word) + (declare (type ,word-offset dst-word-offset) + (type ,byte-offset dst-byte-offset)) + (multiple-value-bind (n-words final-bytes) + (floor (+ dst-byte-offset length) ,bytes-per-word) + (declare (type ,word-offset n-words) + (type ,byte-offset final-bytes)) + (if (zerop n-words) + ,(unless (= bytes-per-word 1) + `(unless (zerop length) + (locally (declare (type ,byte-count length)) + (funcall dst-set-fn dst dst-word-offset + (if (= length ,bytes-per-word) + value + (let ((mask (shift-towards-end + (start-mask (* length ,bitsize)) + (* dst-byte-offset ,bitsize)))) + (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-bytes) ,bytes-per-word))) + ,@(unless (= bytes-per-word 1) + `((unless (zerop dst-byte-offset) + (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize)))) + (funcall dst-set-fn dst dst-word-offset + (word-logical-or (word-logical-and value mask) + (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset) + mask)))) + (incf dst-word-offset)))) + (dotimes (i interior) + (funcall dst-set-fn dst dst-word-offset value) + (incf dst-word-offset)) + ,@(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 (funcall dst-ref-fn dst dst-word-offset) + mask))))))))))) + (values)) -(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)))) + ;; common uses for constant-byte-bashing + (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)) + (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))) + (multiple-value-bind (dst dst-offset) (,fix-sap-and-offset-name dst dst-offset) + (,constant-bash-name 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))) + ;; unary byte bashing (copying) + (defun ,unary-bash-name (src src-offset dst dst-offset length + dst-ref-fn dst-set-fn src-ref-fn) + (declare (type index src-offset dst-offset length) + (type function dst-ref-fn dst-set-fn src-ref-fn) + (ignorable dst-ref-fn)) + (multiple-value-bind (dst-word-offset dst-byte-offset) + (floor dst-offset ,bytes-per-word) + (declare (type ,word-offset dst-word-offset) + (type ,byte-offset dst-byte-offset)) + (multiple-value-bind (src-word-offset src-byte-offset) + (floor src-offset ,bytes-per-word) + (declare (type ,word-offset src-word-offset) + (type ,byte-offset src-byte-offset)) + (cond + ((<= (+ dst-byte-offset length) ,bytes-per-word) + ;; 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) + ;; We're not writing anything. This is really easy. + ) + ((= length ,bytes-per-word) + ;; DST-BYTE-OFFSET must be equal to zero, or we would be + ;; writing multiple words. If SRC-BYTE-OFFSET is also zero, + ;; the we just transfer the single word. Otherwise we have + ;; to extract bytes from two source words. + (funcall dst-set-fn dst dst-word-offset + (cond + ((zerop src-byte-offset) + (funcall src-ref-fn src src-word-offset)) + ,@(unless (= bytes-per-word 1) + `((t (word-logical-or (shift-towards-start + (funcall src-ref-fn src src-word-offset) + (* src-byte-offset ,bitsize)) + (shift-towards-end + (funcall src-ref-fn src (1+ src-word-offset)) + (* (- src-byte-offset) ,bitsize))))))))) + ,@(unless (= bytes-per-word 1) + `((t + ;; We are only writing some portion of the destination word. + ;; We still don't know whether we need one or two source words. + (locally (declare (type ,byte-count length)) + (let ((mask (shift-towards-end (start-mask (* length ,bitsize)) + (* dst-byte-offset ,bitsize))) + (orig (funcall dst-ref-fn dst dst-word-offset)) + (value (if (> src-byte-offset dst-byte-offset) + ;; The source starts further + ;; into the word than does the + ;; destination, so the source + ;; could extend into the next + ;; word. If it does, we have + ;; to merge the two words, and + ;; it not, we can just shift + ;; the first word. + (let ((src-byte-shift (- src-byte-offset + dst-byte-offset))) + (if (> (+ src-byte-offset length) ,bytes-per-word) + (word-logical-or + (shift-towards-start + (funcall src-ref-fn src src-word-offset) + (* src-byte-shift ,bitsize)) + (shift-towards-end + (funcall src-ref-fn src (1+ src-word-offset)) + (* (- src-byte-shift) ,bitsize))) + (shift-towards-start (funcall src-ref-fn src src-word-offset) + (* src-byte-shift ,bitsize)))) + ;; The destination starts further + ;; into the word than does the + ;; source, so we know the source + ;; cannot extend into a second + ;; word (or else the destination + ;; would too, and we wouldn't be + ;; in this branch). + (shift-towards-end + (funcall src-ref-fn src src-word-offset) + (* (- dst-byte-offset src-byte-offset) ,bitsize))))) + (declare (type word mask orig value)) + (funcall dst-set-fn dst dst-word-offset + (word-logical-or (word-logical-and value mask) + (word-logical-andc2 orig mask)))))))))) + ((= src-byte-offset dst-byte-offset) + ;; The source and destination are aligned, so shifting + ;; is unnecessary. But we have to pick the direction + ;; of the copy in case the source and destination are + ;; really the same object. + (multiple-value-bind (words final-bytes) + (floor (+ dst-byte-offset length) ,bytes-per-word) + (declare (type ,word-offset words) + (type ,byte-offset final-bytes)) + (let ((interior (floor (- length final-bytes) ,bytes-per-word))) + (declare (type ,word-offset interior)) + (cond + ((<= dst-offset src-offset) + ;; We need to loop from left to right. + ,@(unless (= bytes-per-word 1) + `((unless (zerop dst-byte-offset) + ;; We are only writing part of the first word, so mask + ;; off the bytes we want to preserve. + (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize))) + (orig (funcall dst-ref-fn dst dst-word-offset)) + (value (funcall src-ref-fn src src-word-offset))) + (declare (type word mask orig value)) + (funcall dst-set-fn dst dst-word-offset + (word-logical-or (word-logical-and value mask) + (word-logical-andc2 orig mask)))) + (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)) + ,@(unless (= bytes-per-word 1) + `((unless (zerop final-bytes) + ;; We are only writing part of the last word. + (let ((mask (start-mask (* final-bytes ,bitsize))) + (orig (funcall dst-ref-fn dst dst-word-offset)) + (value (funcall src-ref-fn src src-word-offset))) + (declare (type word mask orig value)) + (funcall dst-set-fn dst dst-word-offset + (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) + (incf src-word-offset words) + ,@(unless (= bytes-per-word 1) + `((unless (zerop final-bytes) + (let ((mask (start-mask (* final-bytes ,bitsize))) + (orig (funcall dst-ref-fn dst dst-word-offset)) + (value (funcall src-ref-fn src src-word-offset))) + (declare (type word mask orig value)) + (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))) + ,@(unless (= bytes-per-word 1) + `((unless (zerop dst-byte-offset) + ;; We are only writing part of the last word. + (decf src-word-offset) + (decf dst-word-offset) + (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize))) + (orig (funcall dst-ref-fn dst dst-word-offset)) + (value (funcall src-ref-fn src src-word-offset))) + (declare (type word mask orig value)) + (funcall dst-set-fn dst dst-word-offset + (word-logical-or (word-logical-and value mask) + (word-logical-andc2 orig mask)))))))))))) + (t + ;; Source and destination are not aligned. + (multiple-value-bind (words final-bytes) + (floor (+ dst-byte-offset length) ,bytes-per-word) + (declare (type ,word-offset words) + (type ,byte-offset final-bytes)) + (let ((src-shift (mod (- src-byte-offset dst-byte-offset) + ,bytes-per-word)) + (interior (floor (- length final-bytes) ,bytes-per-word))) + (declare (type ,word-offset interior) + (type ,byte-offset src-shift)) + (cond + ((<= dst-offset src-offset) + ;; We need to loop from left to right. + (let ((prev 0) + (next (funcall src-ref-fn src src-word-offset))) + (declare (type word prev next)) + (flet ((get-next-src () + (setf prev next) + (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) + (when (> src-byte-offset dst-byte-offset) + (get-next-src)) + (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize))) + (orig (funcall dst-ref-fn dst dst-word-offset)) + (value (word-logical-or (shift-towards-start prev (* src-shift ,bitsize)) + (shift-towards-end next (* (- src-shift) ,bitsize))))) + (declare (type word mask orig value)) + (funcall dst-set-fn dst dst-word-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))) + ,@(unless (= bytes-per-word 1) + `((unless (zerop final-bytes) + (let ((value + (if (> (+ final-bytes src-shift) ,bytes-per-word) + (progn + (get-next-src) + (word-logical-or + (shift-towards-end next (* (- src-shift) ,bitsize)) + (shift-towards-start prev (* src-shift ,bitsize)))) + (shift-towards-start next (* src-shift ,bitsize)))) + (mask (start-mask (* final-bytes ,bitsize))) + (orig (funcall dst-ref-fn dst dst-word-offset))) + (declare (type word mask orig value)) + (funcall dst-set-fn dst dst-word-offset + (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) + (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)) + (flet ((get-next-src () + (setf next prev) + (setf prev (funcall src-ref-fn src (decf src-word-offset))))) + (declare (inline get-next-src)) + ,@(unless (= bytes-per-word 1) + `((unless (zerop final-bytes) + (when (> final-bytes (- ,bytes-per-word src-shift)) + (get-next-src)) + (let ((value (word-logical-or + (shift-towards-end next (* (- src-shift) ,bitsize)) + (shift-towards-start prev (* src-shift ,bitsize)))) + (mask (start-mask (* final-bytes ,bitsize))) + (orig (funcall dst-ref-fn dst dst-word-offset))) + (declare (type word mask orig value)) + (funcall dst-set-fn dst dst-word-offset + (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))) + ,@(unless (= bytes-per-word 1) + `((unless (zerop dst-byte-offset) + (if (> src-byte-offset dst-byte-offset) + (get-next-src) + (setf next prev prev 0)) + (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize))) + (orig (funcall dst-ref-fn dst dst-word-offset)) + (value (word-logical-or + (shift-towards-start prev (* src-shift ,bitsize)) + (shift-towards-end next (* (- src-shift) ,bitsize))))) + (declare (type word mask orig value)) + (funcall dst-set-fn dst dst-word-offset + (word-logical-or (word-logical-and value mask) + (word-logical-andc2 orig mask))))))))))))))))) + (values)) -(defun system-area-copy (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) - (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))))) + ;; common uses for unary-byte-bashing + (defun ,array-copy-name (src src-offset dst dst-offset length) + (declare (type ,offset src-offset dst-offset length)) + (locally (declare (optimize (speed 3) (safety 1))) + (,unary-bash-name src src-offset dst dst-offset length + #'%vector-raw-bits + #'%set-vector-raw-bits + #'%vector-raw-bits))) -(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)))) + (defun ,system-area-copy-name (src src-offset dst dst-offset length) + (declare (type ,offset src-offset dst-offset length)) + (locally (declare (optimize (speed 3) (safety 1))) + (multiple-value-bind (src src-offset) (,fix-sap-and-offset-name src src-offset) + (declare (type sb!sys:system-area-pointer src)) + (multiple-value-bind (dst dst-offset) (,fix-sap-and-offset-name dst dst-offset) + (declare (type sb!sys:system-area-pointer dst)) + (,unary-bash-name src src-offset dst dst-offset length + #'word-sap-ref #'%set-word-sap-ref + #'word-sap-ref))))) -(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)))) + (defun ,array-copy-to-system-area-name (src src-offset dst dst-offset length) + (declare (type ,offset src-offset dst-offset length)) + (locally (declare (optimize (speed 3) (safety 1))) + (multiple-value-bind (dst dst-offset) (,fix-sap-and-offset-name dst dst-offset) + (,unary-bash-name src src-offset dst dst-offset length + #'word-sap-ref #'%set-word-sap-ref + #'%vector-raw-bits)))) + (defun ,system-area-copy-to-array-name (src src-offset dst dst-offset length) + (declare (type ,offset src-offset dst-offset length)) + (locally (declare (optimize (speed 3) (safety 1))) + (multiple-value-bind (src src-offset) (,fix-sap-and-offset-name src src-offset) + (,unary-bash-name src src-offset dst dst-offset length + #'%vector-raw-bits + #'%set-vector-raw-bits + #'word-sap-ref))))))) +) ; EVAL-WHEN + +;;; We would normally do this with a MACROLET, but then we run into +;;; problems with the lexical environment being too hairy for the +;;; cross-compiler and it cannot inline the basic basher functions. +#.(loop for i = 1 then (* i 2) + collect `(!define-sap-fixer ,i) into fixers + collect `(!define-byte-bashers ,i) into bashers + until (= i sb!vm:n-word-bits) + ;; FIXERS must come first so their inline expansions are available + ;; for the bashers. + finally (return `(progn ,@fixers ,@bashers))) + ;;; a common idiom for calling COPY-TO-SYSTEM-AREA ;;; ;;; Copy the entire contents of the vector V to memory starting at SAP+OFFSET. (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? - (copy-to-system-area bv - (* sb!vm:vector-data-offset sb!vm:word-bits) - sap - offset - (* (length bv) sb!vm:byte-bits))) + (copy-ub8-to-system-area bv 0 sap offset (length bv)))