diff --git a/code/bit-bash.lisp b/code/bit-bash.lisp index 5df64588b74380f2a786df9cb4a0a6aa662eda7e..07f51881814643aed28aebb936289765aaeb21b3 100644 --- a/code/bit-bash.lisp +++ b/code/bit-bash.lisp @@ -1,4 +1,4 @@ -;;; -*- Log: code.log; Package: Lisp -*- +;;; -*- Log: code.log; Package: VM -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bit-bash.lisp,v 1.8 1991/02/08 13:31:12 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bit-bash.lisp,v 1.9 1991/04/13 21:04:47 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -16,7 +16,7 @@ ;;; Written by William Lott. ;;; -(in-package "LISP") +(in-package "VM") @@ -25,7 +25,7 @@ (eval-when (compile load eval) -(defconstant unit-bits 32 +(defconstant unit-bits vm:word-bits "The number of bits to process at a time.") (defconstant max-bits (ash most-positive-fixnum -2) @@ -41,6 +41,9 @@ (deftype bit-offset () `(integer 0 (,unit-bits))) +(deftype bit-count () + `(integer 1 (,unit-bits))) + (deftype word-offset () `(integer 0 (,(ceiling max-bits unit-bits)))) @@ -48,336 +51,426 @@ ); eval-when - -;;;; Macros for generating bit-bashing routines. - - -(eval-when (compile eval) - -(defmacro end-bits (count) - "Returns the byte spec for COUNT bits at the end of a word, i.e. the bits - at the largest address." - (ecase (c:backend-byte-order c:*backend*) - (:little-endian `(byte ,count (- unit-bits ,count))) - (:big-endian `(byte ,count 0)))) - -(defmacro start-bits (count) - "Returns the byte spec for COUNT bits at the start of a word, i.e. the bits - at the smallest address." - (ecase (c:backend-byte-order c:*backend*) - (:little-endian `(byte ,count 0)) - (:big-endian `(byte ,count (- unit-bits ,count))))) - -(defmacro middle-bits (count where) - "Return the byte spec for COUNT bits starting at bit WHERE. WHERE of zero - corresponds to the start of the word (lowest address) and WHERE of - unit-bits corresponds to the end of the word (highest address). In other - words, act like :little-endian" - (ecase (c:backend-byte-order c:*backend*) - (:little-endian `(byte ,count ,where)) - (:big-endian `(byte ,count (- unit-bits ,where ,count))))) - - -(defmacro bit-bash-bindings (&body guts) - `(let* ((final-bits (mod (+ len dst-bit-offset) unit-bits)) - (interior (floor (- len final-bits) unit-bits))) - (declare (type bit-offset final-bits) - (type word-offset interior)) - ,@guts)) - -(defmacro bind-srcs ((kind incf-p ref-fn) &body body) - (ecase kind - (:constant `(progn - ,@body - ,@(when incf-p - `((incf dst-word-offset))))) - (:unary `(let ((next-1 (,ref-fn src-1 src-1-word-offset))) - (declare (type unit next-1)) - ,@body - ,@(when incf-p - '((incf dst-word-offset) - (incf src-1-word-offset))))) - (:binary `(let ((next-1 (,ref-fn src-1 src-1-word-offset)) - (next-2 (,ref-fn src-2 src-2-word-offset))) - (declare (type unit next-1 next-2)) - ,@body - ,@(when incf-p - '((incf dst-word-offset) - (incf src-1-word-offset) - (incf src-2-word-offset))))))) - - -(defmacro bit-bash-loop (kind ref-fn set-fn function &optional update) - `(progn - (unless (zerop dst-bit-offset) - (bind-srcs (,kind t ,ref-fn) - (setf (,set-fn dst dst-word-offset) - (the unit - (dpb ,function - (end-bits (the (integer (0) (#.unit-bits)) - (- unit-bits dst-bit-offset))) - (,set-fn dst dst-word-offset)))) - ,update)) - (dotimes (count interior) - (declare (type word-offset count)) - (bind-srcs (,kind t ,ref-fn) - (setf (,set-fn dst dst-word-offset) ,function) - ,update)) - (unless (zerop final-bits) - (bind-srcs (,kind nil ,ref-fn) - (setf (,set-fn dst dst-word-offset) - (the unit - (dpb ,function - (start-bits (the (integer (0) (#.unit-bits)) - final-bits)) - (,set-fn dst dst-word-offset)))))))) - - -(defun pick-args (op kind arg1 arg2) - (ecase kind - (:constant - op) - (:unary - (list op arg1)) - (:binary - (list op arg1 arg2)))) - -(defmacro def-bit-basher (name op &optional (kind :binary) (ref-fn '%raw-bits) - (set-fn ref-fn)) - (let ((form - `(cond - ((<= (+ dst-bit-offset len) unit-bits) - ;; It's narrow. - (setf (,set-fn dst dst-word-offset) - (the unit - (dpb (the unit - ,(pick-args op kind - `(the unit - (ldb (middle-bits (the bit-offset len) - src-1-bit-offset) - (,ref-fn src-1 - src-1-word-offset))) - `(the unit - (ldb (middle-bits (the bit-offset len) - src-2-bit-offset) - (,ref-fn src-2 - src-2-word-offset))))) - (middle-bits len dst-bit-offset) - (,set-fn dst dst-word-offset))))) - (,(ecase kind - (:constant t) - (:unary '(= src-1-bit-offset dst-bit-offset)) - (:binary '(= src-1-bit-offset src-2-bit-offset dst-bit-offset))) - ;; Everything is aligned evenly. - (bit-bash-bindings - (bit-bash-loop ,kind ,ref-fn ,set-fn - ,(pick-args op kind 'next-1 'next-2)))) - ,@(when (eq kind :binary) - `(((= src-1-bit-offset dst-bit-offset) - ;; Src1 and the destination are aligned, but src2 is not. - (bit-bash-bindings - (when (> dst-bit-offset src-2-bit-offset) - (decf src-2-word-offset)) - (let* ((src-2-shift - (mod (- dst-offset src-2-offset) unit-bits)) - (prev-2 (,ref-fn src-2 src-2-word-offset))) - (declare (type bit-offset src-2-shift)) - (declare (type unit prev-2)) - (incf src-2-word-offset) - (bit-bash-loop ,kind ,ref-fn ,set-fn - (,op next-1 (merge-bits src-2-shift prev-2 next-2)) - (setf prev-2 next-2))))) - ((= src-2-bit-offset - dst-bit-offset) - ;; Src2 and the destination are aligned, but src1 is not. - (bit-bash-bindings - (when (> dst-bit-offset src-1-bit-offset) - (decf src-1-word-offset)) - (let* ((src-1-shift - (mod (- dst-offset src-1-offset) unit-bits)) - (prev-1 (,ref-fn src-1 src-1-word-offset))) - (declare (type bit-offset src-1-shift)) - (declare (type unit prev-1)) - (incf src-1-word-offset) - (bit-bash-loop ,kind ,ref-fn ,set-fn - (,op (merge-bits src-1-shift prev-1 next-1) next-2) - (setf prev-1 next-1))))))) - ,@(unless (eq kind :constant) - `((t - ;; Nothing is aligned. Ack. - (bit-bash-bindings - (when (> dst-bit-offset src-1-bit-offset) - (decf src-1-word-offset)) - ,@(when (eq kind :binary) - '((when (> dst-bit-offset src-2-bit-offset) - (decf src-2-word-offset)))) - (let* ((src-1-shift - (mod (- dst-offset src-1-offset) unit-bits)) - (prev-1 (,ref-fn src-1 src-1-word-offset)) - ,@(when (eq kind :binary) - `((src-2-shift - (mod (- dst-offset src-2-offset) unit-bits)) - (prev-2 (,ref-fn src-2 src-2-word-offset))))) - (declare (type bit-offset src-1-shift - ,@(when (eq kind :binary) - '(src-2-shift))) - (type unit prev-1 - ,@(when (eq kind :binary) '(prev-2)))) - (incf src-1-word-offset) - ,@(when (eq kind :binary) - '((incf src-2-word-offset))) - (bit-bash-loop ,kind ,ref-fn ,set-fn - ,(pick-args op kind - '(merge-bits src-1-shift prev-1 next-1) - '(merge-bits src-2-shift prev-2 next-2)) - (setf prev-1 next-1 - ,@(when (eq kind :binary) - '(prev-2 next-2))))))))))) - (function-args '(len)) - (function-decls '(len))) - (dolist (arg (ecase kind - (:constant '(dst)) - (:unary '(dst src-1)) - (:binary '(dst src-2 src-1)))) - (let* ((name (string arg)) - (offset - (intern (concatenate 'simple-string name "-OFFSET"))) - (bit-offset - (intern (concatenate 'simple-string name "-BIT-OFFSET"))) - (word-offset - (intern (concatenate 'simple-string name "-WORD-OFFSET")))) - (setf form - `(multiple-value-bind (,word-offset ,bit-offset) - (floor ,offset unit-bits) - (declare (type word-offset ,word-offset) - (type bit-offset ,bit-offset)) - ,form)) - (push offset function-args) - (push offset function-decls) - (push arg function-args))) - `(defun ,name ,function-args - (declare (type offset ,@function-decls)) - ,form))) - -); eval when - ;;;; Support routines. -;;; These are compiler primitives. - -(defun %raw-bits (object offset) - (declare (type index offset)) - (%raw-bits object offset)) - -(defun %set-raw-bits (object offset value) - (declare (type index offset) - (type unit value)) - (setf (%raw-bits object offset) value)) - -(defun merge-bits (shift prev next) - "Return (ldb (byte 32 0) (ash (logior (ash prev 32) next) (- shift))) but - stay out of bignum land." - (declare (type bit-offset shift) - (type unit prev next)) - (merge-bits shift prev next)) - - -;;; These are supported as primitives. - -(defun 32bit-logical-not (x) - (32bit-logical-not x)) - -(defun 32bit-logical-and (x y) - (32bit-logical-and x y)) - -(defun 32bit-logical-or (x y) - (32bit-logical-or x y)) - -(defun 32bit-logical-xor (x y) - (32bit-logical-or x y)) - -(defun 32bit-logical-nor (x y) - (32bit-logical-nor x y)) - - -;;; These are not supported as primitives. - -(proclaim '(inline 32bit-logical-eqv 32bit-logical-nand 32bit-logical-andc1 - 32bit-logical-andc2 32bit-logical-orc1 32bit-logical-orc2)) - -(defun 32bit-logical-eqv (x y) - (32bit-logical-not (32bit-logical-xor x y))) - -(defun 32bit-logical-nand (x y) - (32bit-logical-not (32bit-logical-and x y))) - -(defun 32bit-logical-andc1 (x y) - (32bit-logical-and (32bit-logical-not x) y)) +;;; A particular implementation must offer either VOPs to translate these, or +;;; deftransforms to convert them into something supported by the architecture. +;;; +(macrolet ((frob (name &rest args) + `(defun ,name ,args + (,name ,@args)))) + (frob 32bit-logical-not x) + (frob 32bit-logical-and x y) + (frob 32bit-logical-or x y) + (frob 32bit-logical-xor x y) + (frob 32bit-logical-nor x y) + (frob 32bit-logical-eqv x y) + (frob 32bit-logical-nand x y) + (frob 32bit-logical-andc1 x y) + (frob 32bit-logical-andc2 x y) + (frob 32bit-logical-orc1 x y) + (frob 32bit-logical-orc2 x y)) -(defun 32bit-logical-andc2 (x y) - (32bit-logical-and x (32bit-logical-not y))) -(defun 32bit-logical-orc1 (x y) - (32bit-logical-or (32bit-logical-not x) y)) +(eval-when (compile eval) + (defmacro byte-order-dispatch (big-endian little-endian) + (ecase (c:backend-byte-order c:*target-backend*) + (:big-endian big-endian) + (:little-endian little-endian)))) + +(defun shift-towards-start (number count) + "Shift NUMBER by COUNT bits, 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. Note: only the low 5 bits + of count are significant." + (declare (type unit number) (fixnum count)) + (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count))) + (declare (type bit-offset count)) + (if (zerop count) + number + (byte-order-dispatch + (ash (ldb (byte (- unit-bits count) 0) number) count) + (ash number (- count)))))) + +(defun shift-towards-end (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." + (declare (type unit number) (fixnum count)) + (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count))) + (declare (type bit-offset count)) + (if (zerop count) + number + (byte-order-dispatch + (ash number (- count)) + (ash (ldb (byte (- unit-bits count) 0) number) count))))) + +(proclaim '(inline start-mask end-mask)) +(defun start-mask (count) + "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))) + +(defun end-mask (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." + (declare (fixnum count)) + (shift-towards-end (1- (ash 1 unit-bits)) (- count))) -(defun 32bit-logical-orc2 (x y) - (32bit-logical-or x (32bit-logical-not y))) + +;;;; DO-CONSTANT-BIT-BASH + +(proclaim '(inline do-constant-bit-bash)) +(defun do-constant-bit-bash (dst dst-offset length value dst-ref-fn dst-set-fn) + "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))))))))) + (undefined-value)) + +;;;; DO-UNARY-BIT-BASH + +(proclaim '(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 arn't even writing one word. This is real 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 if 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 arn'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) + (shift-towards-start next src-shift) + (progn + (get-next-src) + (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)))))))) + (t + ;; We need to loop from right to left. + (incf dst-word-offset words) + (incf src-word-offset + (floor (+ 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) + (unless (> (- unit-bits src-shift) final-bits) + (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))))))))))))))) + (undefined-value)) ;;;; The actual bashers. -#| - -(proclaim '(optimize (speed 3) (safety 0))) - -(def-bit-basher bit-bash-clear 0 :constant) -(def-bit-basher bit-bash-set (1- (ash 1 unit-bits)) :constant) - -(def-bit-basher bit-bash-not 32bit-logical-not :unary) +(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))) -(def-bit-basher bit-bash-and 32bit-logical-and) -(def-bit-basher bit-bash-ior 32bit-logical-or) -(def-bit-basher bit-bash-xor 32bit-logical-xor) -(def-bit-basher bit-bash-eqv 32bit-logical-eqv) -(def-bit-basher bit-bash-nand 32bit-logical-nand) -(def-bit-basher bit-bash-nor 32bit-logical-nor) -(def-bit-basher bit-bash-andc1 32bit-logical-andc1) -(def-bit-basher bit-bash-andc2 32bit-logical-andc2) -(def-bit-basher bit-bash-orc1 32bit-logical-orc1) -(def-bit-basher bit-bash-orc2 32bit-logical-orc2) +(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))) + (do-constant-bit-bash dst dst-offset length value + #'sap-ref-32 #'%set-sap-ref-32))) +(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))) -;;; Sap-ref-32 can be used to index into SAP objects. - -(def-bit-basher system-area-clear 0 :constant sap-ref-32) - -|# - - -;;;; Copy routines. - -;;; These are written in assembler. +(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))) + (do-unary-bit-bash src src-offset dst dst-offset length + #'sap-ref-32 #'%set-sap-ref-32 #'sap-ref-32))) (defun copy-to-system-area (src src-offset dst dst-offset length) - (declare (type (simple-unboxed-array (*)) src) - (type system-area-pointer dst) - (type index src-offset dst-offset length)) - (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))) + (do-unary-bit-bash src src-offset dst dst-offset length + #'sap-ref-32 #'%set-sap-ref-32 #'%raw-bits))) (defun copy-from-system-area (src src-offset dst dst-offset length) - (declare (type system-area-pointer src) - (type (simple-unboxed-array (*)) dst) - (type index src-offset dst-offset length)) - (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))) + (do-unary-bit-bash src src-offset dst dst-offset length + #'%raw-bits #'%set-raw-bits #'sap-ref-32))) -(defun system-area-copy (src src-offset dst dst-offset length) - (declare (type system-area-pointer src dst) - (type index src-offset dst-offset length)) - (system-area-copy src src-offset dst dst-offset length)) - -(defun bit-bash-copy (src src-offset dst dst-offset length) - (declare (type (simple-unboxed-array (*)) src dst) - (type index src-offset dst-offset length)) - (bit-bash-copy src src-offset dst dst-offset length))