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 (defconstant unit-bits sb!vm:word-bits
18 "The number of bits to process at a time.")
20 (defconstant max-bits (ash most-positive-fixnum -2)
22 "The maximum number of bits that can be delt with during a single call.")
24 ;;; FIXME: Do we really need EVAL-WHEN around these DEFTYPEs?
25 (eval-when (:compile-toplevel :load-toplevel :execute)
28 `(unsigned-byte ,unit-bits))
31 `(integer 0 ,max-bits))
33 (deftype bit-offset ()
34 `(integer 0 (,unit-bits)))
37 `(integer 1 (,unit-bits)))
39 (deftype word-offset ()
40 `(integer 0 (,(ceiling max-bits unit-bits))))
46 ;;; A particular implementation must offer either VOPs to translate
47 ;;; these, or DEFTRANSFORMs to convert them into something supported
48 ;;; by the architecture.
49 (macrolet ((def-frob (name &rest args)
52 (def-frob 32bit-logical-not x)
53 (def-frob 32bit-logical-and x y)
54 (def-frob 32bit-logical-or x y)
55 (def-frob 32bit-logical-xor x y)
56 (def-frob 32bit-logical-nor x y)
57 (def-frob 32bit-logical-eqv x y)
58 (def-frob 32bit-logical-nand x y)
59 (def-frob 32bit-logical-andc1 x y)
60 (def-frob 32bit-logical-andc2 x y)
61 (def-frob 32bit-logical-orc1 x y)
62 (def-frob 32bit-logical-orc2 x y))
64 (defun shift-towards-start (number countoid)
66 "Shift NUMBER by the low-order bits of COUNTOID, adding zero bits at
67 the ``end'' and removing bits from the ``start.'' On big-endian
68 machines this is a left-shift and on little-endian machines this is a
70 (declare (type unit number) (fixnum countoid))
71 (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) countoid)))
72 (declare (type bit-offset count))
75 (ecase sb!c:*backend-byte-order*
77 (ash (ldb (byte (- unit-bits count) 0) number) count))
79 (ash number (- count)))))))
81 (defun shift-towards-end (number count)
83 "Shift NUMBER by COUNT bits, adding zero bits at the ``start'' and removing
84 bits from the ``end.'' On big-endian machines this is a right-shift and
85 on little-endian machines this is a left-shift."
86 (declare (type unit number) (fixnum count))
87 (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count)))
88 (declare (type bit-offset count))
91 (ecase sb!c:*backend-byte-order*
93 (ash number (- count)))
95 (ash (ldb (byte (- unit-bits count) 0) number) count))))))
97 #!-sb-fluid (declaim (inline start-mask end-mask fix-sap-and-offset))
98 (defun start-mask (count)
100 "Produce a mask that contains 1's for the COUNT ``start'' bits and 0's for
101 the remaining ``end'' bits. Only the lower 5 bits of COUNT are significant."
102 (declare (fixnum count))
103 (shift-towards-start (1- (ash 1 unit-bits)) (- count)))
105 (defun end-mask (count)
107 "Produce a mask that contains 1's for the COUNT ``end'' bits and 0's for
108 the remaining ``start'' bits. Only the lower 5 bits of COUNT are
110 (declare (fixnum count))
111 (shift-towards-end (1- (ash 1 unit-bits)) (- count)))
113 (defun fix-sap-and-offset (sap offset)
115 "Align the SAP to a word boundary, and update the offset accordingly."
116 (declare (type system-area-pointer sap)
118 (values system-area-pointer index))
119 (let ((address (sap-int sap)))
120 (values (int-sap #!-alpha (32bit-logical-andc2 address 3)
121 #!+alpha (ash (ash address -2) 2))
122 (+ (* (logand address 3) byte-bits) offset))))
124 #!-sb-fluid (declaim (inline word-sap-ref %set-word-sap-ref))
125 (defun word-sap-ref (sap offset)
126 (declare (type system-area-pointer sap)
128 (values (unsigned-byte 32))
129 (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3)))
130 (sap-ref-32 sap (the index (ash offset 2))))
131 (defun %set-word-sap-ref (sap offset value)
132 (declare (type system-area-pointer sap)
134 (type (unsigned-byte 32) value)
135 (values (unsigned-byte 32))
136 (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
137 (setf (sap-ref-32 sap (the index (ash offset 2))) value))
139 ;;;; DO-CONSTANT-BIT-BASH
141 #!-sb-fluid (declaim (inline do-constant-bit-bash))
142 (defun do-constant-bit-bash (dst dst-offset length value dst-ref-fn dst-set-fn)
144 "Fill DST with VALUE starting at DST-OFFSET and continuing for LENGTH bits."
145 (declare (type offset dst-offset) (type unit value)
146 (type function dst-ref-fn dst-set-fn))
147 (multiple-value-bind (dst-word-offset dst-bit-offset)
148 (floor dst-offset unit-bits)
149 (declare (type word-offset dst-word-offset)
150 (type bit-offset dst-bit-offset))
151 (multiple-value-bind (words final-bits)
152 (floor (+ dst-bit-offset length) unit-bits)
153 (declare (type word-offset words) (type bit-offset final-bits))
155 (unless (zerop length)
156 (funcall dst-set-fn dst dst-word-offset
157 (if (= length unit-bits)
159 (let ((mask (shift-towards-end (start-mask length)
161 (declare (type unit mask))
163 (32bit-logical-and value mask)
165 (funcall dst-ref-fn dst dst-word-offset)
167 (let ((interior (floor (- length final-bits) unit-bits)))
168 (unless (zerop dst-bit-offset)
169 (let ((mask (end-mask (- dst-bit-offset))))
170 (declare (type unit mask))
171 (funcall dst-set-fn dst dst-word-offset
173 (32bit-logical-and value mask)
175 (funcall dst-ref-fn dst dst-word-offset)
177 (incf dst-word-offset))
178 (dotimes (i interior)
179 (funcall dst-set-fn dst dst-word-offset value)
180 (incf dst-word-offset))
181 (unless (zerop final-bits)
182 (let ((mask (start-mask final-bits)))
183 (declare (type unit mask))
184 (funcall dst-set-fn dst dst-word-offset
186 (32bit-logical-and value mask)
188 (funcall dst-ref-fn dst dst-word-offset)
192 ;;;; DO-UNARY-BIT-BASH
194 #!-sb-fluid (declaim (inline do-unary-bit-bash))
195 (defun do-unary-bit-bash (src src-offset dst dst-offset length
196 dst-ref-fn dst-set-fn src-ref-fn)
197 (declare (type offset src-offset dst-offset length)
198 (type function dst-ref-fn dst-set-fn src-ref-fn))
199 (multiple-value-bind (dst-word-offset dst-bit-offset)
200 (floor dst-offset unit-bits)
201 (declare (type word-offset dst-word-offset)
202 (type bit-offset dst-bit-offset))
203 (multiple-value-bind (src-word-offset src-bit-offset)
204 (floor src-offset unit-bits)
205 (declare (type word-offset src-word-offset)
206 (type bit-offset src-bit-offset))
208 ((<= (+ dst-bit-offset length) unit-bits)
209 ;; We are only writing one word, so it doesn't matter what order
210 ;; we do it in. But we might be reading from multiple words, so take
214 ;; Actually, we aren't even writing one word. This is really easy.
216 ((= length unit-bits)
217 ;; DST-BIT-OFFSET must be equal to zero, or we would be writing
218 ;; multiple words. If SRC-BIT-OFFSET is also zero, then we
219 ;; just transfer the single word. Otherwise we have to extract bits
220 ;; from two src words.
221 (funcall dst-set-fn dst dst-word-offset
222 (if (zerop src-bit-offset)
223 (funcall src-ref-fn src src-word-offset)
226 (funcall src-ref-fn src src-word-offset)
229 (funcall src-ref-fn src (1+ src-word-offset))
230 (- src-bit-offset))))))
232 ;; We are only writing some portion of the dst word, so we need to
233 ;; preserve the extra bits. Also, we still don't know whether we need
234 ;; one or two source words.
235 (let ((mask (shift-towards-end (start-mask length) dst-bit-offset))
236 (orig (funcall dst-ref-fn dst dst-word-offset))
238 (if (> src-bit-offset dst-bit-offset)
239 ;; The source starts further into the word than does
240 ;; the dst, so the source could extend into the next
241 ;; word. If it does, we have to merge the two words,
242 ;; and if not, we can just shift the first word.
243 (let ((src-bit-shift (- src-bit-offset dst-bit-offset)))
244 (if (> (+ src-bit-offset length) unit-bits)
247 (funcall src-ref-fn src src-word-offset)
250 (funcall src-ref-fn src (1+ src-word-offset))
253 (funcall src-ref-fn src src-word-offset)
255 ;; The dst starts further into the word than does the
256 ;; source, so we know the source can not extend into
257 ;; a second word (or else the dst would too, and we
258 ;; wouldn't be in this branch.
260 (funcall src-ref-fn src src-word-offset)
261 (- dst-bit-offset src-bit-offset)))))
262 (declare (type unit mask orig value))
263 ;; Replace the dst word.
264 (funcall dst-set-fn dst dst-word-offset
266 (32bit-logical-and value mask)
267 (32bit-logical-andc2 orig mask)))))))
268 ((= src-bit-offset dst-bit-offset)
269 ;; The source and dst are aligned, so we don't need to shift
270 ;; anything. But we have to pick the direction of the loop
271 ;; in case the source and dst are really the same thing.
272 (multiple-value-bind (words final-bits)
273 (floor (+ dst-bit-offset length) unit-bits)
274 (declare (type word-offset words) (type bit-offset final-bits))
275 (let ((interior (floor (- length final-bits) unit-bits)))
276 (declare (type word-offset interior))
278 ((<= dst-offset src-offset)
279 ;; We need to loop from left to right
280 (unless (zerop dst-bit-offset)
281 ;; We are only writing part of the first word, so mask off the
282 ;; bits we want to preserve.
283 (let ((mask (end-mask (- dst-bit-offset)))
284 (orig (funcall dst-ref-fn dst dst-word-offset))
285 (value (funcall src-ref-fn src src-word-offset)))
286 (declare (type unit mask orig value))
287 (funcall dst-set-fn dst dst-word-offset
288 (32bit-logical-or (32bit-logical-and value mask)
289 (32bit-logical-andc2 orig mask))))
290 (incf src-word-offset)
291 (incf dst-word-offset))
292 ;; Just copy the interior words.
293 (dotimes (i interior)
294 (funcall dst-set-fn dst dst-word-offset
295 (funcall src-ref-fn src src-word-offset))
296 (incf src-word-offset)
297 (incf dst-word-offset))
298 (unless (zerop final-bits)
299 ;; We are only writing part of the last word.
300 (let ((mask (start-mask final-bits))
301 (orig (funcall dst-ref-fn dst dst-word-offset))
302 (value (funcall src-ref-fn src src-word-offset)))
303 (declare (type unit mask orig value))
304 (funcall dst-set-fn dst dst-word-offset
306 (32bit-logical-and value mask)
307 (32bit-logical-andc2 orig mask))))))
309 ;; We need to loop from right to left.
310 (incf dst-word-offset words)
311 (incf src-word-offset words)
312 (unless (zerop final-bits)
313 (let ((mask (start-mask final-bits))
314 (orig (funcall dst-ref-fn dst dst-word-offset))
315 (value (funcall src-ref-fn src src-word-offset)))
316 (declare (type unit mask orig value))
317 (funcall dst-set-fn dst dst-word-offset
319 (32bit-logical-and value mask)
320 (32bit-logical-andc2 orig mask)))))
321 (dotimes (i interior)
322 (decf src-word-offset)
323 (decf dst-word-offset)
324 (funcall dst-set-fn dst dst-word-offset
325 (funcall src-ref-fn src src-word-offset)))
326 (unless (zerop dst-bit-offset)
327 (decf src-word-offset)
328 (decf dst-word-offset)
329 (let ((mask (end-mask (- dst-bit-offset)))
330 (orig (funcall dst-ref-fn dst dst-word-offset))
331 (value (funcall src-ref-fn src src-word-offset)))
332 (declare (type unit mask orig value))
333 (funcall dst-set-fn dst dst-word-offset
335 (32bit-logical-and value mask)
336 (32bit-logical-andc2 orig mask))))))))))
338 ;; They aren't aligned.
339 (multiple-value-bind (words final-bits)
340 (floor (+ dst-bit-offset length) unit-bits)
341 (declare (type word-offset words) (type bit-offset final-bits))
342 (let ((src-shift (mod (- src-bit-offset dst-bit-offset) unit-bits))
343 (interior (floor (- length final-bits) unit-bits)))
344 (declare (type bit-offset src-shift)
345 (type word-offset interior))
347 ((<= dst-offset src-offset)
348 ;; We need to loop from left to right
350 (next (funcall src-ref-fn src src-word-offset)))
351 (declare (type unit prev next))
352 (flet ((get-next-src ()
354 (setf next (funcall src-ref-fn src
355 (incf src-word-offset)))))
356 (declare (inline get-next-src))
357 (unless (zerop dst-bit-offset)
358 (when (> src-bit-offset dst-bit-offset)
360 (let ((mask (end-mask (- dst-bit-offset)))
361 (orig (funcall dst-ref-fn dst dst-word-offset))
362 (value (32bit-logical-or
363 (shift-towards-start prev src-shift)
364 (shift-towards-end next (- src-shift)))))
365 (declare (type unit mask orig value))
366 (funcall dst-set-fn dst dst-word-offset
368 (32bit-logical-and value mask)
369 (32bit-logical-andc2 orig mask)))
370 (incf dst-word-offset)))
371 (dotimes (i interior)
373 (let ((value (32bit-logical-or
374 (shift-towards-end next (- src-shift))
375 (shift-towards-start prev src-shift))))
376 (declare (type unit value))
377 (funcall dst-set-fn dst dst-word-offset value)
378 (incf dst-word-offset)))
379 (unless (zerop final-bits)
381 (if (> (+ final-bits src-shift) unit-bits)
385 (shift-towards-end next (- src-shift))
386 (shift-towards-start prev src-shift)))
387 (shift-towards-start next src-shift)))
388 (mask (start-mask final-bits))
389 (orig (funcall dst-ref-fn dst dst-word-offset)))
390 (declare (type unit mask orig value))
391 (funcall dst-set-fn dst dst-word-offset
393 (32bit-logical-and value mask)
394 (32bit-logical-andc2 orig mask))))))))
396 ;; We need to loop from right to left.
397 (incf dst-word-offset words)
398 (incf src-word-offset
399 (1- (ceiling (+ src-bit-offset length) unit-bits)))
401 (prev (funcall src-ref-fn src src-word-offset)))
402 (declare (type unit prev next))
403 (flet ((get-next-src ()
405 (setf prev (funcall src-ref-fn src
406 (decf src-word-offset)))))
407 (declare (inline get-next-src))
408 (unless (zerop final-bits)
409 (when (> final-bits (- unit-bits src-shift))
411 (let ((value (32bit-logical-or
412 (shift-towards-end next (- src-shift))
413 (shift-towards-start prev src-shift)))
414 (mask (start-mask final-bits))
415 (orig (funcall dst-ref-fn dst dst-word-offset)))
416 (declare (type unit mask orig value))
417 (funcall dst-set-fn dst dst-word-offset
419 (32bit-logical-and value mask)
420 (32bit-logical-andc2 orig mask)))))
421 (decf dst-word-offset)
422 (dotimes (i interior)
424 (let ((value (32bit-logical-or
425 (shift-towards-end next (- src-shift))
426 (shift-towards-start prev src-shift))))
427 (declare (type unit value))
428 (funcall dst-set-fn dst dst-word-offset value)
429 (decf dst-word-offset)))
430 (unless (zerop dst-bit-offset)
431 (if (> src-bit-offset dst-bit-offset)
433 (setf next prev prev 0))
434 (let ((mask (end-mask (- dst-bit-offset)))
435 (orig (funcall dst-ref-fn dst dst-word-offset))
436 (value (32bit-logical-or
437 (shift-towards-start prev src-shift)
438 (shift-towards-end next (- src-shift)))))
439 (declare (type unit mask orig value))
440 (funcall dst-set-fn dst dst-word-offset
442 (32bit-logical-and value mask)
443 (32bit-logical-andc2 orig mask)))))))))))))))
446 ;;;; the actual bashers
448 (defun bit-bash-fill (value dst dst-offset length)
449 (declare (type unit value) (type offset dst-offset length))
451 (declare (optimize (speed 3) (safety 0)))
452 (do-constant-bit-bash dst dst-offset length value
453 #'%raw-bits #'%set-raw-bits)))
455 (defun system-area-fill (value dst dst-offset length)
456 (declare (type unit value) (type offset dst-offset length))
458 (declare (optimize (speed 3) (safety 0)))
459 (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
460 (do-constant-bit-bash dst dst-offset length value
461 #'word-sap-ref #'%set-word-sap-ref))))
463 (defun bit-bash-copy (src src-offset dst dst-offset length)
464 (declare (type offset src-offset dst-offset length))
466 (declare (optimize (speed 3) (safety 0))
467 (inline do-unary-bit-bash))
468 (do-unary-bit-bash src src-offset dst dst-offset length
469 #'%raw-bits #'%set-raw-bits #'%raw-bits)))
471 (defun system-area-copy (src src-offset dst dst-offset length)
472 (declare (type offset src-offset dst-offset length))
474 (declare (optimize (speed 3) (safety 0)))
475 (multiple-value-bind (src src-offset) (fix-sap-and-offset src src-offset)
476 (declare (type system-area-pointer src))
477 (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
478 (declare (type system-area-pointer dst))
479 (do-unary-bit-bash src src-offset dst dst-offset length
480 #'word-sap-ref #'%set-word-sap-ref
483 (defun copy-to-system-area (src src-offset dst dst-offset length)
484 (declare (type offset src-offset dst-offset length))
486 (declare (optimize (speed 3) (safety 0)))
487 (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
488 (do-unary-bit-bash src src-offset dst dst-offset length
489 #'word-sap-ref #'%set-word-sap-ref #'%raw-bits))))
491 (defun copy-from-system-area (src src-offset dst dst-offset length)
492 (declare (type offset src-offset dst-offset length))
494 (declare (optimize (speed 3) (safety 0)))
495 (multiple-value-bind (src src-offset) (fix-sap-and-offset src src-offset)
496 (do-unary-bit-bash src src-offset dst dst-offset length
497 #'%raw-bits #'%set-raw-bits #'word-sap-ref))))
499 ;;; a common idiom for calling COPY-TO-SYSTEM-AREA
501 ;;; Copy the entire contents of the vector V to memory starting at SAP+OFFSET.
502 (defun copy-byte-vector-to-system-area (bv sap &optional (offset 0))
503 ;; FIXME: There should be a type like SB!VM:BYTE so that we can write this
504 ;; type as (SIMPLE-ARRAY SB!VM:BYTE 1). Except BYTE is an external symbol of
505 ;; package CL; so maybe SB!VM:VM-BYTE?
506 (declare (type (simple-array (unsigned-byte 8) 1) bv))
507 (declare (type sap sap))
508 (declare (type fixnum offset))
509 ;; FIXME: Actually it looks as though this, and most other calls
510 ;; to COPY-TO-SYSTEM-AREA, could be written more concisely with BYTE-BLT.
511 ;; Except that the DST-END-DST-START convention for the length is confusing.
512 ;; Perhaps I could rename BYTE-BLT to BYTE-BLIT and replace the
513 ;; DST-END argument with an N-BYTES argument?
514 (copy-to-system-area bv
515 (* sb!vm:vector-data-offset sb!vm:word-bits)
518 (* (length bv) sb!vm:byte-bits)))