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