Skip to content
Snippets Groups Projects
Commit e2495999 authored by wlott's avatar wlott
Browse files

Rewrote everything to simplity porting to different machines.

parent 596b7a7e
No related branches found
No related tags found
No related merge requests found
;;; -*- 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))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment