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.
14 ;;;; constants and types
16 ;;; the number of bits to process at a time
17 (defconstant unit-bits n-word-bits
)
19 ;;; the maximum number of bits that can be dealt with in a single call
20 (defconstant max-bits
(ash most-positive-fixnum -
2))
23 `(unsigned-byte ,unit-bits
))
26 `(integer 0 ,max-bits
))
28 (deftype bit-offset
()
29 `(integer 0 (,unit-bits
)))
32 `(integer 1 (,unit-bits
)))
34 (deftype word-offset
()
35 `(integer 0 (,(ceiling max-bits unit-bits
))))
39 ;;; A particular implementation must offer either VOPs to translate
40 ;;; these, or DEFTRANSFORMs to convert them into something supported
41 ;;; by the architecture.
42 (macrolet ((def (name &rest args
)
45 (def 32bit-logical-not x
)
46 (def 32bit-logical-and x y
)
47 (def 32bit-logical-or x y
)
48 (def 32bit-logical-xor x y
)
49 (def 32bit-logical-nor x y
)
50 (def 32bit-logical-eqv x y
)
51 (def 32bit-logical-nand x y
)
52 (def 32bit-logical-andc1 x y
)
53 (def 32bit-logical-andc2 x y
)
54 (def 32bit-logical-orc1 x y
)
55 (def 32bit-logical-orc2 x y
))
57 ;;; Shift NUMBER by the low-order bits of COUNTOID, adding zero bits
58 ;;; at the "end" and removing bits from the "start". On big-endian
59 ;;; machines this is a left-shift and on little-endian machines this
61 (defun shift-towards-start (number countoid
)
62 (declare (type unit number
) (fixnum countoid
))
63 (let ((count (ldb (byte (1- (integer-length unit-bits
)) 0) countoid
)))
64 (declare (type bit-offset count
))
67 (ecase sb
!c
:*backend-byte-order
*
69 (ash (ldb (byte (- unit-bits count
) 0) number
) count
))
71 (ash number
(- count
)))))))
73 ;;; Shift NUMBER by COUNT bits, adding zero bits at the "start" and
74 ;;; removing bits from the "end". On big-endian machines this is a
75 ;;; right-shift and on little-endian machines this is a left-shift.
76 (defun shift-towards-end (number count
)
77 (declare (type unit number
) (fixnum count
))
78 (let ((count (ldb (byte (1- (integer-length unit-bits
)) 0) count
)))
79 (declare (type bit-offset count
))
82 (ecase sb
!c
:*backend-byte-order
*
84 (ash number
(- count
)))
86 (ash (ldb (byte (- unit-bits count
) 0) number
) count
))))))
88 #!-sb-fluid
(declaim (inline start-mask end-mask fix-sap-and-offset
))
90 ;;; Produce a mask that contains 1's for the COUNT "start" bits and
91 ;;; 0's for the remaining "end" bits. Only the lower 5 bits of COUNT
92 ;;; are significant (KLUDGE: because of hardwired implicit dependence
93 ;;; on 32-bit word size -- WHN 2001-03-19).
94 (defun start-mask (count)
95 (declare (fixnum count
))
96 (shift-towards-start (1- (ash 1 unit-bits
)) (- count
)))
98 ;;; Produce a mask that contains 1's for the COUNT "end" bits and 0's
99 ;;; for the remaining "start" bits. Only the lower 5 bits of COUNT are
100 ;;; significant (KLUDGE: because of hardwired implicit dependence on
101 ;;; 32-bit word size -- WHN 2001-03-19).
102 (defun end-mask (count)
103 (declare (fixnum count
))
104 (shift-towards-end (1- (ash 1 unit-bits
)) (- count
)))
106 ;;; Align the SAP to a word boundary, and update the offset accordingly.
107 (defun fix-sap-and-offset (sap offset
)
108 (declare (type system-area-pointer sap
)
110 (values system-area-pointer index
))
111 (let ((address (sap-int sap
)))
112 (values (int-sap #!-alpha
(32bit-logical-andc2 address
3)
113 #!+alpha
(ash (ash address -
2) 2))
114 (+ (* (logand address
3) n-byte-bits
) offset
))))
116 #!-sb-fluid
(declaim (inline word-sap-ref %set-word-sap-ref
))
117 (defun word-sap-ref (sap offset
)
118 (declare (type system-area-pointer sap
)
120 (values (unsigned-byte 32))
121 (optimize (speed 3) (safety 0) #-sb-xc-host
(inhibit-warnings 3)))
122 (sap-ref-32 sap
(the index
(ash offset
2))))
123 (defun %set-word-sap-ref
(sap offset value
)
124 (declare (type system-area-pointer sap
)
126 (type (unsigned-byte 32) value
)
127 (values (unsigned-byte 32))
128 (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
129 (setf (sap-ref-32 sap
(the index
(ash offset
2))) value
))
131 ;;;; CONSTANT-BIT-BASH
133 ;;; Fill DST with VALUE starting at DST-OFFSET and continuing for
135 #!-sb-fluid
(declaim (inline constant-bit-bash
))
136 (defun constant-bit-bash (dst dst-offset length value dst-ref-fn dst-set-fn
)
137 (declare (type offset dst-offset
) (type unit value
)
138 (type function dst-ref-fn dst-set-fn
))
139 (multiple-value-bind (dst-word-offset dst-bit-offset
)
140 (floor dst-offset unit-bits
)
141 (declare (type word-offset dst-word-offset
)
142 (type bit-offset dst-bit-offset
))
143 (multiple-value-bind (words final-bits
)
144 (floor (+ dst-bit-offset length
) unit-bits
)
145 (declare (type word-offset words
) (type bit-offset final-bits
))
147 (unless (zerop length
)
148 (funcall dst-set-fn dst dst-word-offset
149 (if (= length unit-bits
)
151 (let ((mask (shift-towards-end (start-mask length
)
153 (declare (type unit mask
))
155 (32bit-logical-and value mask
)
157 (funcall dst-ref-fn dst dst-word-offset
)
159 (let ((interior (floor (- length final-bits
) unit-bits
)))
160 (unless (zerop dst-bit-offset
)
161 (let ((mask (end-mask (- dst-bit-offset
))))
162 (declare (type unit mask
))
163 (funcall dst-set-fn dst dst-word-offset
165 (32bit-logical-and value mask
)
167 (funcall dst-ref-fn dst dst-word-offset
)
169 (incf dst-word-offset
))
170 (dotimes (i interior
)
171 (funcall dst-set-fn dst dst-word-offset value
)
172 (incf dst-word-offset
))
173 (unless (zerop final-bits
)
174 (let ((mask (start-mask final-bits
)))
175 (declare (type unit mask
))
176 (funcall dst-set-fn dst dst-word-offset
178 (32bit-logical-and value mask
)
180 (funcall dst-ref-fn dst dst-word-offset
)
186 #!-sb-fluid
(declaim (inline unary-bit-bash
))
187 (defun unary-bit-bash (src src-offset dst dst-offset length
188 dst-ref-fn dst-set-fn src-ref-fn
)
189 ;; FIXME: Declaring these bit indices to be of type OFFSET, then
190 ;; using the inline expansion in SPEED 3 SAFETY 0 functions, is not
191 ;; a good thing. At the very least, we should make sure that the
192 ;; type (overflow) checks get done. Better would be to avoid
193 ;; using bit indices, and to use 32-bit unsigneds instead, and/or
194 ;; to call out to things like memmove(3) for big moves.
195 (declare (type offset src-offset dst-offset length
)
196 (type function dst-ref-fn dst-set-fn src-ref-fn
))
197 (multiple-value-bind (dst-word-offset dst-bit-offset
)
198 (floor dst-offset unit-bits
)
199 (declare (type word-offset dst-word-offset
)
200 (type bit-offset dst-bit-offset
))
201 (multiple-value-bind (src-word-offset src-bit-offset
)
202 (floor src-offset unit-bits
)
203 (declare (type word-offset src-word-offset
)
204 (type bit-offset src-bit-offset
))
206 ((<= (+ dst-bit-offset length
) unit-bits
)
207 ;; We are only writing one word, so it doesn't matter what
208 ;; order we do it in. But we might be reading from multiple
209 ;; words, so take care.
212 ;; Actually, we aren't even writing one word. This is really easy.
214 ((= length unit-bits
)
215 ;; DST-BIT-OFFSET must be equal to zero, or we would be
216 ;; writing multiple words. If SRC-BIT-OFFSET is also zero,
217 ;; then we just transfer the single word. Otherwise we have
218 ;; to extract bits from two src words.
219 (funcall dst-set-fn dst dst-word-offset
220 (if (zerop src-bit-offset
)
221 (funcall src-ref-fn src src-word-offset
)
224 (funcall src-ref-fn src src-word-offset
)
227 (funcall src-ref-fn src
(1+ src-word-offset
))
228 (- src-bit-offset
))))))
230 ;; We are only writing some portion of the dst word, so we
231 ;; need to preserve the extra bits. Also, we still don't
232 ;; know whether we need one or two source words.
233 (let ((mask (shift-towards-end (start-mask length
) dst-bit-offset
))
234 (orig (funcall dst-ref-fn dst dst-word-offset
))
236 (if (> src-bit-offset dst-bit-offset
)
237 ;; The source starts further into the word than
238 ;; does the dst, so the source could extend into
239 ;; the next word. If it does, we have to merge
240 ;; the two words, and if not, we can just shift
242 (let ((src-bit-shift (- src-bit-offset dst-bit-offset
)))
243 (if (> (+ src-bit-offset length
) unit-bits
)
246 (funcall src-ref-fn src src-word-offset
)
249 (funcall src-ref-fn src
(1+ src-word-offset
))
252 (funcall src-ref-fn src src-word-offset
)
254 ;; The dst starts further into the word than does
255 ;; the source, so we know the source can not
256 ;; extend into a second word (or else the dst
257 ;; would too, and we wouldn't be in this branch.
259 (funcall src-ref-fn src src-word-offset
)
260 (- dst-bit-offset src-bit-offset
)))))
261 (declare (type unit mask orig value
))
262 ;; Replace the dst word.
263 (funcall dst-set-fn dst dst-word-offset
265 (32bit-logical-and value mask
)
266 (32bit-logical-andc2 orig mask
)))))))
267 ((= src-bit-offset dst-bit-offset
)
268 ;; The source and dst are aligned, so we don't need to shift
269 ;; anything. But we have to pick the direction of the loop in
270 ;; case the source and dst are really the same thing.
271 (multiple-value-bind (words final-bits
)
272 (floor (+ dst-bit-offset length
) unit-bits
)
273 (declare (type word-offset words
) (type bit-offset final-bits
))
274 (let ((interior (floor (- length final-bits
) unit-bits
)))
275 (declare (type word-offset interior
))
277 ((<= dst-offset src-offset
)
278 ;; We need to loop from left to right
279 (unless (zerop dst-bit-offset
)
280 ;; We are only writing part of the first word, so mask
281 ;; off the bits we want to preserve.
282 (let ((mask (end-mask (- dst-bit-offset
)))
283 (orig (funcall dst-ref-fn dst dst-word-offset
))
284 (value (funcall src-ref-fn src src-word-offset
)))
285 (declare (type unit mask orig value
))
286 (funcall dst-set-fn dst dst-word-offset
287 (32bit-logical-or (32bit-logical-and value mask
)
288 (32bit-logical-andc2 orig mask
))))
289 (incf src-word-offset
)
290 (incf dst-word-offset
))
291 ;; Just copy the interior words.
292 (dotimes (i interior
)
293 (funcall dst-set-fn dst dst-word-offset
294 (funcall src-ref-fn src src-word-offset
))
295 (incf src-word-offset
)
296 (incf dst-word-offset
))
297 (unless (zerop final-bits
)
298 ;; We are only writing part of the last word.
299 (let ((mask (start-mask final-bits
))
300 (orig (funcall dst-ref-fn dst dst-word-offset
))
301 (value (funcall src-ref-fn src src-word-offset
)))
302 (declare (type unit mask orig value
))
303 (funcall dst-set-fn dst dst-word-offset
305 (32bit-logical-and value mask
)
306 (32bit-logical-andc2 orig mask
))))))
308 ;; We need to loop from right to left.
309 (incf dst-word-offset words
)
310 (incf src-word-offset words
)
311 (unless (zerop final-bits
)
312 (let ((mask (start-mask final-bits
))
313 (orig (funcall dst-ref-fn dst dst-word-offset
))
314 (value (funcall src-ref-fn src src-word-offset
)))
315 (declare (type unit mask orig value
))
316 (funcall dst-set-fn dst dst-word-offset
318 (32bit-logical-and value mask
)
319 (32bit-logical-andc2 orig mask
)))))
320 (dotimes (i interior
)
321 (decf src-word-offset
)
322 (decf dst-word-offset
)
323 (funcall dst-set-fn dst dst-word-offset
324 (funcall src-ref-fn src src-word-offset
)))
325 (unless (zerop dst-bit-offset
)
326 (decf src-word-offset
)
327 (decf dst-word-offset
)
328 (let ((mask (end-mask (- dst-bit-offset
)))
329 (orig (funcall dst-ref-fn dst dst-word-offset
))
330 (value (funcall src-ref-fn src src-word-offset
)))
331 (declare (type unit mask orig value
))
332 (funcall dst-set-fn dst dst-word-offset
334 (32bit-logical-and value mask
)
335 (32bit-logical-andc2 orig mask
))))))))))
337 ;; They aren't aligned.
338 (multiple-value-bind (words final-bits
)
339 (floor (+ dst-bit-offset length
) unit-bits
)
340 (declare (type word-offset words
) (type bit-offset final-bits
))
341 (let ((src-shift (mod (- src-bit-offset dst-bit-offset
) unit-bits
))
342 (interior (floor (- length final-bits
) unit-bits
)))
343 (declare (type bit-offset src-shift
)
344 (type word-offset interior
))
346 ((<= dst-offset src-offset
)
347 ;; We need to loop from left to right
349 (next (funcall src-ref-fn src src-word-offset
)))
350 (declare (type unit prev next
))
351 (flet ((get-next-src ()
353 (setf next
(funcall src-ref-fn src
354 (incf src-word-offset
)))))
355 (declare (inline get-next-src
))
356 (unless (zerop dst-bit-offset
)
357 (when (> src-bit-offset dst-bit-offset
)
359 (let ((mask (end-mask (- dst-bit-offset
)))
360 (orig (funcall dst-ref-fn dst dst-word-offset
))
361 (value (32bit-logical-or
362 (shift-towards-start prev src-shift
)
363 (shift-towards-end next
(- src-shift
)))))
364 (declare (type unit mask orig value
))
365 (funcall dst-set-fn dst dst-word-offset
367 (32bit-logical-and value mask
)
368 (32bit-logical-andc2 orig mask
)))
369 (incf dst-word-offset
)))
370 (dotimes (i interior
)
372 (let ((value (32bit-logical-or
373 (shift-towards-end next
(- src-shift
))
374 (shift-towards-start prev src-shift
))))
375 (declare (type unit value
))
376 (funcall dst-set-fn dst dst-word-offset value
)
377 (incf dst-word-offset
)))
378 (unless (zerop final-bits
)
380 (if (> (+ final-bits src-shift
) unit-bits
)
384 (shift-towards-end next
(- src-shift
))
385 (shift-towards-start prev src-shift
)))
386 (shift-towards-start next src-shift
)))
387 (mask (start-mask final-bits
))
388 (orig (funcall dst-ref-fn dst dst-word-offset
)))
389 (declare (type unit mask orig value
))
390 (funcall dst-set-fn dst dst-word-offset
392 (32bit-logical-and value mask
)
393 (32bit-logical-andc2 orig mask
))))))))
395 ;; We need to loop from right to left.
396 (incf dst-word-offset words
)
397 (incf src-word-offset
398 (1- (ceiling (+ src-bit-offset length
) unit-bits
)))
400 (prev (funcall src-ref-fn src src-word-offset
)))
401 (declare (type unit prev next
))
402 (flet ((get-next-src ()
404 (setf prev
(funcall src-ref-fn src
405 (decf src-word-offset
)))))
406 (declare (inline get-next-src
))
407 (unless (zerop final-bits
)
408 (when (> final-bits
(- unit-bits src-shift
))
410 (let ((value (32bit-logical-or
411 (shift-towards-end next
(- src-shift
))
412 (shift-towards-start prev src-shift
)))
413 (mask (start-mask final-bits
))
414 (orig (funcall dst-ref-fn dst dst-word-offset
)))
415 (declare (type unit mask orig value
))
416 (funcall dst-set-fn dst dst-word-offset
418 (32bit-logical-and value mask
)
419 (32bit-logical-andc2 orig mask
)))))
420 (decf dst-word-offset
)
421 (dotimes (i interior
)
423 (let ((value (32bit-logical-or
424 (shift-towards-end next
(- src-shift
))
425 (shift-towards-start prev src-shift
))))
426 (declare (type unit value
))
427 (funcall dst-set-fn dst dst-word-offset value
)
428 (decf dst-word-offset
)))
429 (unless (zerop dst-bit-offset
)
430 (if (> src-bit-offset dst-bit-offset
)
432 (setf next prev prev
0))
433 (let ((mask (end-mask (- dst-bit-offset
)))
434 (orig (funcall dst-ref-fn dst dst-word-offset
))
435 (value (32bit-logical-or
436 (shift-towards-start prev src-shift
)
437 (shift-towards-end next
(- src-shift
)))))
438 (declare (type unit mask orig value
))
439 (funcall dst-set-fn dst dst-word-offset
441 (32bit-logical-and value mask
)
442 (32bit-logical-andc2 orig mask
)))))))))))))))
445 ;;;; the actual bashers
447 (defun bit-bash-fill (value dst dst-offset length
)
448 (declare (type unit value
) (type offset dst-offset length
))
450 (declare (optimize (speed 3) (safety 0)))
451 (constant-bit-bash dst dst-offset length value
452 #'%raw-bits
#'%set-raw-bits
)))
454 (defun system-area-fill (value dst dst-offset length
)
455 (declare (type unit value
) (type offset dst-offset length
))
457 (declare (optimize (speed 3) (safety 0)))
458 (multiple-value-bind (dst dst-offset
) (fix-sap-and-offset dst dst-offset
)
459 (constant-bit-bash dst dst-offset length value
460 #'word-sap-ref
#'%set-word-sap-ref
))))
462 (defun bit-bash-copy (src src-offset dst dst-offset length
)
463 (declare (type offset src-offset dst-offset length
))
465 (declare (optimize (speed 3) (safety 0))
466 (inline unary-bit-bash
))
467 (unary-bit-bash src src-offset dst dst-offset length
468 #'%raw-bits
#'%set-raw-bits
#'%raw-bits
)))
470 (defun system-area-copy (src src-offset dst dst-offset length
)
471 (declare (type offset src-offset dst-offset length
))
473 (declare (optimize (speed 3) (safety 0)))
474 (multiple-value-bind (src src-offset
) (fix-sap-and-offset src src-offset
)
475 (declare (type system-area-pointer src
))
476 (multiple-value-bind (dst dst-offset
) (fix-sap-and-offset dst dst-offset
)
477 (declare (type system-area-pointer dst
))
478 (unary-bit-bash src src-offset dst dst-offset length
479 #'word-sap-ref
#'%set-word-sap-ref
482 (defun copy-to-system-area (src src-offset dst dst-offset length
)
483 (declare (type offset src-offset dst-offset length
))
485 (declare (optimize (speed 3) (safety 0)))
486 (multiple-value-bind (dst dst-offset
) (fix-sap-and-offset dst dst-offset
)
487 (unary-bit-bash src src-offset dst dst-offset length
488 #'word-sap-ref
#'%set-word-sap-ref
#'%raw-bits
))))
490 (defun copy-from-system-area (src src-offset dst dst-offset length
)
491 (declare (type offset src-offset dst-offset length
))
493 (declare (optimize (speed 3) (safety 0)))
494 (multiple-value-bind (src src-offset
) (fix-sap-and-offset src src-offset
)
495 (unary-bit-bash src src-offset dst dst-offset length
496 #'%raw-bits
#'%set-raw-bits
#'word-sap-ref
))))
498 ;;; a common idiom for calling COPY-TO-SYSTEM-AREA
500 ;;; Copy the entire contents of the vector V to memory starting at SAP+OFFSET.
501 (defun copy-byte-vector-to-system-area (bv sap
&optional
(offset 0))
502 ;; FIXME: There should be a type like SB!VM:BYTE so that we can write this
503 ;; type as (SIMPLE-ARRAY SB!VM:BYTE 1). Except BYTE is an external symbol of
504 ;; package CL, and shadowing it would be too ugly; so maybe SB!VM:VMBYTE?
505 ;; (And then N-BYTE-BITS would be N-VMBYTE-BITS and so forth?)
506 (declare (type (simple-array (unsigned-byte 8) 1) bv
))
507 (declare (type system-area-pointer sap
))
508 (declare (type fixnum offset
))
509 ;; FIXME: Actually it looks as though this, and most other calls to
510 ;; COPY-TO-SYSTEM-AREA, could be written more concisely with
511 ;; %BYTE-BLT. Except that the DST-END-DST-START convention for the
512 ;; length is confusing. Perhaps I could rename %BYTE-BLT to
513 ;; %BYTE-BLIT (and correspondingly rename the corresponding VOP) and
514 ;; replace the DST-END argument with an N-BYTES argument?
515 (copy-to-system-area bv
516 (* vector-data-offset n-word-bits
)
519 (* (length bv
) n-byte-bits
)))