0.9.13.30
[sbcl.git] / src / code / bit-bash.lisp
1 ;;;; functions to implement bitblt-ish operations
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!VM")
13 \f
14 ;;;; types
15
16 (deftype bit-offset () '(integer 0 (#.sb!vm:n-word-bits)))
17
18 ;;;; support routines
19
20 ;;; A particular implementation must offer either VOPs to translate
21 ;;; these, or DEFTRANSFORMs to convert them into something supported
22 ;;; by the architecture.
23 (macrolet ((def (name &rest args)
24              `(defun ,name ,args
25                 (,name ,@args))))
26   (def word-logical-not x)
27   (def word-logical-and x y)
28   (def word-logical-or x y)
29   (def word-logical-xor x y)
30   (def word-logical-nor x y)
31   (def word-logical-eqv x y)
32   (def word-logical-nand x y)
33   (def word-logical-andc1 x y)
34   (def word-logical-andc2 x y)
35   (def word-logical-orc1 x y)
36   (def word-logical-orc2 x y))
37
38 ;;; Shift NUMBER by the low-order bits of COUNTOID, adding zero bits
39 ;;; at the "end" and removing bits from the "start". On big-endian
40 ;;; machines this is a left-shift and on little-endian machines this
41 ;;; is a right-shift.
42 (defun shift-towards-start (number countoid)
43   (declare (type sb!vm:word number) (fixnum countoid))
44   (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) countoid)))
45     (declare (type bit-offset count))
46     (if (zerop count)
47         number
48         (ecase sb!c:*backend-byte-order*
49           (:big-endian
50            (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count))
51           (:little-endian
52            (ash number (- count)))))))
53
54 ;;; Shift NUMBER by COUNT bits, adding zero bits at the "start" and
55 ;;; removing bits from the "end". On big-endian machines this is a
56 ;;; right-shift and on little-endian machines this is a left-shift.
57 (defun shift-towards-end (number count)
58   (declare (type sb!vm:word number) (fixnum count))
59   (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) count)))
60     (declare (type bit-offset count))
61     (if (zerop count)
62         number
63         (ecase sb!c:*backend-byte-order*
64           (:big-endian
65            (ash number (- count)))
66           (:little-endian
67            (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count))))))
68
69 #!-sb-fluid (declaim (inline start-mask end-mask))
70
71 ;;; Produce a mask that contains 1's for the COUNT "start" bits and
72 ;;; 0's for the remaining "end" bits. Only the lower 5 bits of COUNT
73 ;;; are significant (KLUDGE: because of hardwired implicit dependence
74 ;;; on 32-bit word size -- WHN 2001-03-19).
75 (defun start-mask (count)
76   (declare (fixnum count))
77   (shift-towards-start (1- (ash 1 sb!vm:n-word-bits)) (- count)))
78
79 ;;; Produce a mask that contains 1's for the COUNT "end" bits and 0's
80 ;;; for the remaining "start" bits. Only the lower 5 bits of COUNT are
81 ;;; significant (KLUDGE: because of hardwired implicit dependence on
82 ;;; 32-bit word size -- WHN 2001-03-19).
83 (defun end-mask (count)
84   (declare (fixnum count))
85   (shift-towards-end (1- (ash 1 sb!vm:n-word-bits)) (- count)))
86
87 #!-sb-fluid (declaim (inline word-sap-ref %set-word-sap-ref))
88 (defun word-sap-ref (sap offset)
89   (declare (type system-area-pointer sap)
90            (type index offset)
91            (values sb!vm:word)
92            (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3)))
93   (sap-ref-word sap (the index (ash offset sb!vm:n-fixnum-tag-bits))))
94 (defun %set-word-sap-ref (sap offset value)
95   (declare (type system-area-pointer sap)
96            (type index offset)
97            (type sb!vm:word value)
98            (values sb!vm:word)
99            (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
100   (setf (sap-ref-word sap (the index (ash offset sb!vm:n-fixnum-tag-bits)))
101         value))
102
103 \f
104 ;;; the actual bashers and common uses of same
105
106 ;;; This is a little ugly.  Fixing bug 188 would bring the ability to
107 ;;; wrap a MACROLET or something similar around this whole thing would
108 ;;; make things significantly less ugly.  --njf, 2005-02-23
109 (eval-when (:compile-toplevel :load-toplevel :execute)
110
111 ;;; Align the SAP to a word boundary, and update the offset accordingly.
112 (defmacro !define-sap-fixer (bitsize)
113   (let ((name (intern (format nil "FIX-SAP-AND-OFFSET-UB~D" bitsize))))
114     `(progn
115       (declaim (inline ,name))
116       (defun ,name (sap offset)
117         (declare (type system-area-pointer sap)
118                  (type index offset)
119                  (values system-area-pointer index))
120         (let ((address (sap-int sap)))
121           (values (int-sap #!-alpha (word-logical-andc2 address
122                                                         sb!vm:fixnum-tag-mask)
123                            #!+alpha (ash (ash address -2) 2))
124                   (+ ,(ecase bitsize
125                        (1 '(* (logand address sb!vm:fixnum-tag-mask) n-byte-bits))
126                        (2 '(* (logand address sb!vm:fixnum-tag-mask) (/ n-byte-bits 2)))
127                        (4 '(* (logand address sb!vm:fixnum-tag-mask) (/ n-byte-bits 4)))
128                        ((8 16 32 64) '(logand address sb!vm:fixnum-tag-mask)))
129                      offset)))))))
130
131 ;;; We cheat a little bit by using TRULY-THE in the copying function to
132 ;;; force the compiler to generate good code in the (= BITSIZE
133 ;;; SB!VM:N-WORD-BITS) case.  We don't use TRULY-THE in the other cases
134 ;;; to give the compiler freedom to generate better code.
135 (defmacro !define-byte-bashers (bitsize)
136   (let* ((bytes-per-word (/ n-word-bits bitsize))
137          (byte-offset `(integer 0 (,bytes-per-word)))
138          (byte-count `(integer 1 (,bytes-per-word)))
139          (max-bytes (ash sb!xc:most-positive-fixnum
140                          ;; FIXME: this reflects code contained in the
141                          ;; original bit-bash.lisp, but seems very
142                          ;; nonsensical.  Why shouldn't we be able to
143                          ;; handle M-P-FIXNUM bits?  And if we can't,
144                          ;; are these other shift amounts bogus, too?
145                          (ecase bitsize
146                            (1 -2)
147                            (2 -1)
148                            (4  0)
149                            (8  0)
150                            (16 0)
151                            (32 0)
152                            (64 0))))
153          (offset `(integer 0 ,max-bytes))
154          (max-word-offset (ceiling max-bytes bytes-per-word))
155          (word-offset `(integer 0 ,max-word-offset))
156          (fix-sap-and-offset-name (intern (format nil "FIX-SAP-AND-OFFSET-UB~D" bitsize)))
157          (constant-bash-name (intern (format nil "CONSTANT-UB~D-BASH" bitsize) (find-package "SB!KERNEL")))
158          (array-fill-name (intern (format nil "UB~D-BASH-FILL" bitsize) (find-package "SB!KERNEL")))
159          (system-area-fill-name (intern (format nil "SYSTEM-AREA-UB~D-FILL" bitsize) (find-package "SB!KERNEL")))
160          (unary-bash-name (intern (format nil "UNARY-UB~D-BASH" bitsize) (find-package "SB!KERNEL")))
161          (array-copy-name (intern (format nil "UB~D-BASH-COPY" bitsize) (find-package "SB!KERNEL")))
162          (system-area-copy-name (intern (format nil "SYSTEM-AREA-UB~D-COPY" bitsize) (find-package "SB!KERNEL")))
163          (array-copy-to-system-area-name
164           (intern (format nil "COPY-UB~D-TO-SYSTEM-AREA" bitsize) (find-package "SB!KERNEL")))
165          (system-area-copy-to-array-name
166           (intern (format nil "COPY-UB~D-FROM-SYSTEM-AREA" bitsize)
167                   (find-package "SB!KERNEL"))))
168     `(progn
169       (declaim (inline ,constant-bash-name ,unary-bash-name))
170       ;; Fill DST with VALUE starting at DST-OFFSET and continuing
171       ;; for LENGTH bytes (however bytes are defined).
172       (defun ,constant-bash-name (dst dst-offset length value
173                                       dst-ref-fn dst-set-fn)
174         (declare (type word value) (type index dst-offset length))
175         (declare (ignorable dst-ref-fn))
176         (multiple-value-bind (dst-word-offset dst-byte-offset)
177             (floor dst-offset ,bytes-per-word)
178           (declare (type ,word-offset dst-word-offset)
179                    (type ,byte-offset dst-byte-offset))
180           (multiple-value-bind (n-words final-bytes)
181               (floor (+ dst-byte-offset length) ,bytes-per-word)
182             (declare (type ,word-offset n-words)
183                      (type ,byte-offset final-bytes))
184             (if (zerop n-words)
185                 ,(unless (= bytes-per-word 1)
186                   `(unless (zerop length)
187                     (locally (declare (type ,byte-count length))
188                       (funcall dst-set-fn dst dst-word-offset
189                                (if (= length ,bytes-per-word)
190                                    value
191                                    (let ((mask (shift-towards-end
192                                                 (start-mask (* length ,bitsize))
193                                                 (* dst-byte-offset ,bitsize))))
194                                      (word-logical-or (word-logical-and value mask)
195                                                       (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset)
196                                                                           mask))))))))
197                 (let ((interior (floor (- length final-bytes) ,bytes-per-word)))
198                   ,@(unless (= bytes-per-word 1)
199                      `((unless (zerop dst-byte-offset)
200                          (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize))))
201                            (funcall dst-set-fn dst dst-word-offset
202                                     (word-logical-or (word-logical-and value mask)
203                                                      (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset)
204                                                                          mask))))
205                          (incf dst-word-offset))))
206                   (let ((end (+ dst-word-offset interior)))
207                     (declare (type ,word-offset end))
208                     (do ()
209                         ((>= dst-word-offset end))
210                       (funcall dst-set-fn dst dst-word-offset value)
211                       (incf dst-word-offset)))
212                   #+nil
213                   (dotimes (i interior)
214                     (funcall dst-set-fn dst dst-word-offset value)
215                     (incf dst-word-offset))
216                   ,@(unless (= bytes-per-word 1)
217                      `((unless (zerop final-bytes)
218                          (let ((mask (start-mask (* final-bytes ,bitsize))))
219                            (funcall dst-set-fn dst dst-word-offset
220                                     (word-logical-or (word-logical-and value mask)
221                                                      (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset)
222                                                                          mask)))))))))))
223         (values))
224
225       ;; common uses for constant-byte-bashing
226       (defun ,array-fill-name (value dst dst-offset length)
227         (declare (type word value) (type ,offset dst-offset length))
228         (declare (optimize (speed 3) (safety 1)))
229         (,constant-bash-name dst dst-offset length value
230                              #'%vector-raw-bits #'%set-vector-raw-bits))
231       (defun ,system-area-fill-name (value dst dst-offset length)
232         (declare (type word value) (type ,offset dst-offset length))
233         (declare (optimize (speed 3) (safety 1)))
234         (multiple-value-bind (dst dst-offset) (,fix-sap-and-offset-name dst dst-offset)
235           (,constant-bash-name dst dst-offset length value
236                                #'word-sap-ref #'%set-word-sap-ref)))
237
238          ;; unary byte bashing (copying)
239          (defun ,unary-bash-name (src src-offset dst dst-offset length
240                                       dst-ref-fn dst-set-fn src-ref-fn)
241            (declare (type index src-offset dst-offset length)
242                     (type function dst-ref-fn dst-set-fn src-ref-fn)
243                     (ignorable dst-ref-fn))
244            (multiple-value-bind (dst-word-offset dst-byte-offset)
245                (floor dst-offset ,bytes-per-word)
246              (declare (type ,word-offset dst-word-offset)
247                       (type ,byte-offset dst-byte-offset))
248              (multiple-value-bind (src-word-offset src-byte-offset)
249                  (floor src-offset ,bytes-per-word)
250                (declare (type ,word-offset src-word-offset)
251                         (type ,byte-offset src-byte-offset))
252                (cond
253                  ((<= (+ dst-byte-offset length) ,bytes-per-word)
254                   ;; We are only writing one word, so it doesn't matter what
255                   ;; order we do it in.  But we might be reading from
256                   ;; multiple words, so take care.
257                   (cond
258                     ((zerop length)
259                      ;; We're not writing anything.  This is really easy.
260                      )
261                     ((= length ,bytes-per-word)
262                      ;; DST-BYTE-OFFSET must be equal to zero, or we would be
263                      ;; writing multiple words.  If SRC-BYTE-OFFSET is also zero,
264                      ;; the we just transfer the single word.  Otherwise we have
265                      ;; to extract bytes from two source words.
266                      (funcall dst-set-fn dst dst-word-offset
267                              (cond
268                                ((zerop src-byte-offset)
269                                 (funcall src-ref-fn src src-word-offset))
270                                ,@(unless (= bytes-per-word 1)
271                                   `((t (word-logical-or (shift-towards-start
272                                                          (funcall src-ref-fn src src-word-offset)
273                                                          (* src-byte-offset ,bitsize))
274                                         (shift-towards-end
275                                           (funcall src-ref-fn src (1+ src-word-offset))
276                                           (* (- src-byte-offset) ,bitsize)))))))))
277                     ,@(unless (= bytes-per-word 1)
278                        `((t
279                           ;; We are only writing some portion of the destination word.
280                           ;; We still don't know whether we need one or two source words.
281                           (locally (declare (type ,byte-count length))
282                             (let ((mask (shift-towards-end (start-mask (* length ,bitsize))
283                                                            (* dst-byte-offset ,bitsize)))
284                                   (orig (funcall dst-ref-fn dst dst-word-offset))
285                                   (value (if (> src-byte-offset dst-byte-offset)
286                                              ;; The source starts further
287                                              ;; into the word than does the
288                                              ;; destination, so the source
289                                              ;; could extend into the next
290                                              ;; word.  If it does, we have
291                                              ;; to merge the two words, and
292                                              ;; it not, we can just shift
293                                              ;; the first word.
294                                              (let ((src-byte-shift (- src-byte-offset
295                                                                       dst-byte-offset)))
296                                                (if (> (+ src-byte-offset length) ,bytes-per-word)
297                                                    (word-logical-or
298                                                     (shift-towards-start
299                                                      (funcall src-ref-fn src src-word-offset)
300                                                      (* src-byte-shift ,bitsize))
301                                                     (shift-towards-end
302                                                      (funcall src-ref-fn src (1+ src-word-offset))
303                                                      (* (- src-byte-shift) ,bitsize)))
304                                                    (shift-towards-start (funcall src-ref-fn src src-word-offset)
305                                                                         (* src-byte-shift ,bitsize))))
306                                              ;; The destination starts further
307                                              ;; into the word than does the
308                                              ;; source, so we know the source
309                                              ;; cannot extend into a second
310                                              ;; word (or else the destination
311                                              ;; would too, and we wouldn't be
312                                              ;; in this branch).
313                                              (shift-towards-end
314                                               (funcall src-ref-fn src src-word-offset)
315                                               (* (- dst-byte-offset src-byte-offset) ,bitsize)))))
316                               (declare (type word mask orig value))
317                               (funcall dst-set-fn dst dst-word-offset
318                                        (word-logical-or (word-logical-and value mask)
319                                                         (word-logical-andc2 orig mask))))))))))
320                  ((= src-byte-offset dst-byte-offset)
321                   ;; The source and destination are aligned, so shifting
322                   ;; is unnecessary.  But we have to pick the direction
323                   ;; of the copy in case the source and destination are
324                   ;; really the same object.
325                   (multiple-value-bind (words final-bytes)
326                       (floor (+ dst-byte-offset length) ,bytes-per-word)
327                     (declare (type ,word-offset words)
328                              (type ,byte-offset final-bytes))
329                     (let ((interior (floor (- length final-bytes) ,bytes-per-word)))
330                       (declare (type ,word-offset interior))
331                       (cond
332                         ((<= dst-offset src-offset)
333                          ;; We need to loop from left to right.
334                          ,@(unless (= bytes-per-word 1)
335                             `((unless (zerop dst-byte-offset)
336                                 ;; We are only writing part of the first word, so mask
337                                 ;; off the bytes we want to preserve.
338                                 (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize)))
339                                       (orig (funcall dst-ref-fn dst dst-word-offset))
340                                       (value (funcall src-ref-fn src src-word-offset)))
341                                   (declare (type word mask orig value))
342                                   (funcall dst-set-fn dst dst-word-offset
343                                            (word-logical-or (word-logical-and value mask)
344                                                             (word-logical-andc2 orig mask))))
345                                 (incf src-word-offset)
346                                 (incf dst-word-offset))))
347                          ;; Copy the interior words.
348                          (let ((end ,(if (= bytes-per-word 1)
349                                          `(truly-the ,word-offset
350                                            (+ dst-word-offset interior))
351                                          `(+ dst-word-offset interior))))
352                            (declare (type ,word-offset end))
353                            (do ()
354                                ((>= dst-word-offset end))
355                              (funcall dst-set-fn dst dst-word-offset
356                                       (funcall src-ref-fn src src-word-offset))
357                              ,(if (= bytes-per-word 1)
358                                   `(setf src-word-offset (truly-the ,word-offset (+ src-word-offset 1)))
359                                   `(incf src-word-offset))
360                              (incf dst-word-offset)))
361                          ,@(unless (= bytes-per-word 1)
362                             `((unless (zerop final-bytes)
363                                 ;; We are only writing part of the last word.
364                                 (let ((mask (start-mask (* final-bytes ,bitsize)))
365                                       (orig (funcall dst-ref-fn dst dst-word-offset))
366                                       (value (funcall src-ref-fn src src-word-offset)))
367                                   (declare (type word mask orig value))
368                                   (funcall dst-set-fn dst dst-word-offset
369                                            (word-logical-or (word-logical-and value mask)
370                                                             (word-logical-andc2 orig mask))))))))
371                         (t
372                          ;; We need to loop from right to left.
373                          ,(if (= bytes-per-word 1)
374                               `(setf dst-word-offset (truly-the ,word-offset
375                                                       (+ dst-word-offset words)))
376                               `(incf dst-word-offset words))
377                          ,(if (= bytes-per-word 1)
378                               `(setf src-word-offset (truly-the ,word-offset
379                                                       (+ src-word-offset words)))
380                               `(incf src-word-offset words))
381                          ,@(unless (= bytes-per-word 1)
382                             `((unless (zerop final-bytes)
383                                 (let ((mask (start-mask (* final-bytes ,bitsize)))
384                                       (orig (funcall dst-ref-fn dst dst-word-offset))
385                                       (value (funcall src-ref-fn src src-word-offset)))
386                                   (declare (type word mask orig value))
387                                   (funcall dst-set-fn dst dst-word-offset
388                                            (word-logical-or (word-logical-and value mask)
389                                                             (word-logical-andc2 orig mask)))))))
390                          (let ((end (- dst-word-offset interior)))
391                            (do ()
392                                ((<= dst-word-offset end))
393                              (decf src-word-offset)
394                              (decf dst-word-offset)
395                              (funcall dst-set-fn dst dst-word-offset
396                                       (funcall src-ref-fn src src-word-offset))))
397                          ,@(unless (= bytes-per-word 1)
398                             `((unless (zerop dst-byte-offset)
399                                 ;; We are only writing part of the last word.
400                                 (decf src-word-offset)
401                                 (decf dst-word-offset)
402                                 (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize)))
403                                       (orig (funcall dst-ref-fn dst dst-word-offset))
404                                       (value (funcall src-ref-fn src src-word-offset)))
405                                   (declare (type word mask orig value))
406                                   (funcall dst-set-fn dst dst-word-offset
407                                            (word-logical-or (word-logical-and value mask)
408                                                             (word-logical-andc2 orig mask))))))))))))
409                  (t
410                   ;; Source and destination are not aligned.
411                   (multiple-value-bind (words final-bytes)
412                       (floor (+ dst-byte-offset length) ,bytes-per-word)
413                     (declare (type ,word-offset words)
414                              (type ,byte-offset final-bytes))
415                     (let ((src-shift (mod (- src-byte-offset dst-byte-offset)
416                                           ,bytes-per-word))
417                           (interior (floor (- length final-bytes) ,bytes-per-word)))
418                       (declare (type ,word-offset interior)
419                                (type ,byte-offset src-shift))
420                       (cond
421                         ((<= dst-offset src-offset)
422                          ;; We need to loop from left to right.
423                          (let ((prev 0)
424                                (next (funcall src-ref-fn src src-word-offset)))
425                            (declare (type word prev next))
426                            (flet ((get-next-src ()
427                                     (setf prev next)
428                                     (setf next (funcall src-ref-fn src
429                                                         (setf src-word-offset (incf src-word-offset))))))
430                              (declare (inline get-next-src))
431                              ,@(unless (= bytes-per-word 1)
432                                 `((unless (zerop dst-byte-offset)
433                                     (when (> src-byte-offset dst-byte-offset)
434                                       (get-next-src))
435                                     (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize)))
436                                           (orig (funcall dst-ref-fn dst dst-word-offset))
437                                           (value (word-logical-or (shift-towards-start prev (* src-shift ,bitsize))
438                                                                   (shift-towards-end next (* (- src-shift) ,bitsize)))))
439                                       (declare (type word mask orig value))
440                                       (funcall dst-set-fn dst dst-word-offset
441                                                (word-logical-or (word-logical-and value mask)
442                                                                 (word-logical-andc2 orig mask))))
443                                     (incf dst-word-offset))))
444                              (let ((end (+ dst-word-offset interior)))
445                                (declare (type ,word-offset end))
446                                (do ()
447                                    ((>= dst-word-offset end))
448                                  (get-next-src)
449                                  (let ((value (word-logical-or
450                                                (shift-towards-end next (* (- src-shift) ,bitsize))
451                                                (shift-towards-start prev (* src-shift ,bitsize)))))
452                                    (declare (type word value))
453                                    (funcall dst-set-fn dst dst-word-offset value)
454                                    (incf dst-word-offset))))
455                              ,@(unless (= bytes-per-word 1)
456                                 `((unless (zerop final-bytes)
457                                     (let ((value
458                                            (if (> (+ final-bytes src-shift) ,bytes-per-word)
459                                                (progn
460                                                  (get-next-src)
461                                                  (word-logical-or
462                                                   (shift-towards-end next (* (- src-shift) ,bitsize))
463                                                   (shift-towards-start prev (* src-shift ,bitsize))))
464                                                (shift-towards-start next (* src-shift ,bitsize))))
465                                           (mask (start-mask (* final-bytes ,bitsize)))
466                                           (orig (funcall dst-ref-fn dst dst-word-offset)))
467                                       (declare (type word mask orig value))
468                                       (funcall dst-set-fn dst dst-word-offset
469                                                (word-logical-or (word-logical-and value mask)
470                                                                 (word-logical-andc2 orig mask))))))))))
471                         (t
472                          ;; We need to loop from right to left.
473                          (incf dst-word-offset words)
474                          (incf src-word-offset (1- (ceiling (+ src-byte-offset length) ,bytes-per-word)))
475                          (let ((next 0)
476                                (prev (funcall src-ref-fn src src-word-offset)))
477                            (declare (type word prev next))
478                            (flet ((get-next-src ()
479                                     (setf next prev)
480                                     (setf prev (funcall src-ref-fn src (decf src-word-offset)))))
481                              (declare (inline get-next-src))
482                              ,@(unless (= bytes-per-word 1)
483                                 `((unless (zerop final-bytes)
484                                     (when (> final-bytes (- ,bytes-per-word src-shift))
485                                       (get-next-src))
486                                     (let ((value (word-logical-or
487                                                   (shift-towards-end next (* (- src-shift) ,bitsize))
488                                                   (shift-towards-start prev (* src-shift ,bitsize))))
489                                           (mask (start-mask (* final-bytes ,bitsize)))
490                                           (orig (funcall dst-ref-fn dst dst-word-offset)))
491                                       (declare (type word mask orig value))
492                                       (funcall dst-set-fn dst dst-word-offset
493                                                (word-logical-or (word-logical-and value mask)
494                                                                 (word-logical-andc2 orig mask)))))))
495                              (decf dst-word-offset)
496                              (let ((end (- dst-word-offset interior)))
497                                (do ()
498                                    ((<= dst-word-offset end))
499                                  (get-next-src)
500                                  (let ((value (word-logical-or
501                                                (shift-towards-end next (* (- src-shift) ,bitsize))
502                                                (shift-towards-start prev (* src-shift ,bitsize)))))
503                                    (declare (type word value))
504                                    (funcall dst-set-fn dst dst-word-offset value)
505                                    (decf dst-word-offset))))
506                              ,@(unless (= bytes-per-word 1)
507                                 `((unless (zerop dst-byte-offset)
508                                     (if (> src-byte-offset dst-byte-offset)
509                                         (get-next-src)
510                                         (setf next prev prev 0))
511                                     (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize)))
512                                           (orig (funcall dst-ref-fn dst dst-word-offset))
513                                           (value (word-logical-or
514                                                   (shift-towards-start prev (* src-shift ,bitsize))
515                                                   (shift-towards-end next (* (- src-shift) ,bitsize)))))
516                                       (declare (type word mask orig value))
517                                       (funcall dst-set-fn dst dst-word-offset
518                                               (word-logical-or (word-logical-and value mask)
519                                                                (word-logical-andc2 orig mask)))))))))))))))))
520            (values))
521
522          ;; common uses for unary-byte-bashing
523          (defun ,array-copy-name (src src-offset dst dst-offset length)
524            (declare (type ,offset src-offset dst-offset length))
525            (locally (declare (optimize (speed 3) (safety 1)))
526              (,unary-bash-name src src-offset dst dst-offset length
527                                #'%vector-raw-bits
528                                #'%set-vector-raw-bits
529                                #'%vector-raw-bits)))
530
531          (defun ,system-area-copy-name (src src-offset dst dst-offset length)
532            (declare (type ,offset src-offset dst-offset length))
533            (locally (declare (optimize (speed 3) (safety 1)))
534              (multiple-value-bind (src src-offset) (,fix-sap-and-offset-name src src-offset)
535                (declare (type sb!sys:system-area-pointer src))
536                (multiple-value-bind (dst dst-offset) (,fix-sap-and-offset-name dst dst-offset)
537                  (declare (type sb!sys:system-area-pointer dst))
538                  (,unary-bash-name src src-offset dst dst-offset length
539                                    #'word-sap-ref #'%set-word-sap-ref
540                                    #'word-sap-ref)))))
541
542          (defun ,array-copy-to-system-area-name (src src-offset dst dst-offset length)
543            (declare (type ,offset src-offset dst-offset length))
544            (locally (declare (optimize (speed 3) (safety 1)))
545              (multiple-value-bind (dst dst-offset) (,fix-sap-and-offset-name  dst dst-offset)
546                (,unary-bash-name src src-offset dst dst-offset length
547                                  #'word-sap-ref #'%set-word-sap-ref
548                                  #'%vector-raw-bits))))
549
550          (defun ,system-area-copy-to-array-name (src src-offset dst dst-offset length)
551            (declare (type ,offset src-offset dst-offset length))
552            (locally (declare (optimize (speed 3) (safety 1)))
553              (multiple-value-bind (src src-offset) (,fix-sap-and-offset-name src src-offset)
554                (,unary-bash-name src src-offset dst dst-offset length
555                                  #'%vector-raw-bits
556                                  #'%set-vector-raw-bits
557                                  #'word-sap-ref)))))))
558 ) ; EVAL-WHEN
559
560 ;;; We would normally do this with a MACROLET, but then we run into
561 ;;; problems with the lexical environment being too hairy for the
562 ;;; cross-compiler and it cannot inline the basic basher functions.
563 #.(loop for i = 1 then (* i 2)
564         collect `(!define-sap-fixer ,i) into fixers
565         collect `(!define-byte-bashers ,i) into bashers
566         until (= i sb!vm:n-word-bits)
567         ;; FIXERS must come first so their inline expansions are available
568         ;; for the bashers.
569         finally (return `(progn ,@fixers ,@bashers)))
570 \f
571 ;;; a common idiom for calling COPY-TO-SYSTEM-AREA
572 ;;;
573 ;;; Copy the entire contents of the vector V to memory starting at SAP+OFFSET.
574 (defun copy-byte-vector-to-system-area (bv sap &optional (offset 0))
575   ;; FIXME: There should be a type like SB!VM:BYTE so that we can write this
576   ;; type as (SIMPLE-ARRAY SB!VM:BYTE 1). Except BYTE is an external symbol of
577   ;; package CL, and shadowing it would be too ugly; so maybe SB!VM:VMBYTE?
578   ;; (And then N-BYTE-BITS would be N-VMBYTE-BITS and so forth?)
579   (declare (type (simple-array (unsigned-byte 8) 1) bv))
580   (declare (type system-area-pointer sap))
581   (declare (type fixnum offset))
582   (copy-ub8-to-system-area bv 0 sap offset (length bv)))