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 (eval-when (:compile-toplevel :load-toplevel :execute)
18 (defconstant unit-bits sb!vm:word-bits
20 "The number of bits to process at a time.")
22 (defconstant max-bits (ash most-positive-fixnum -2)
24 "The maximum number of bits that can be delt with during a single call.")
27 `(unsigned-byte ,unit-bits))
30 `(integer 0 ,max-bits))
32 (deftype bit-offset ()
33 `(integer 0 (,unit-bits)))
36 `(integer 1 (,unit-bits)))
38 (deftype word-offset ()
39 `(integer 0 (,(ceiling max-bits unit-bits))))
45 ;;; A particular implementation must offer either VOPs to translate
46 ;;; these, or DEFTRANSFORMs to convert them into something supported
47 ;;; by the architecture.
48 (macrolet ((def-frob (name &rest args)
51 (def-frob 32bit-logical-not x)
52 (def-frob 32bit-logical-and x y)
53 (def-frob 32bit-logical-or x y)
54 (def-frob 32bit-logical-xor x y)
55 (def-frob 32bit-logical-nor x y)
56 (def-frob 32bit-logical-eqv x y)
57 (def-frob 32bit-logical-nand x y)
58 (def-frob 32bit-logical-andc1 x y)
59 (def-frob 32bit-logical-andc2 x y)
60 (def-frob 32bit-logical-orc1 x y)
61 (def-frob 32bit-logical-orc2 x y))
63 (defun shift-towards-start (number countoid)
65 "Shift NUMBER by the low-order bits of COUNTOID, adding zero bits at
66 the ``end'' and removing bits from the ``start.'' On big-endian
67 machines this is a left-shift and on little-endian machines this is a
69 (declare (type unit number) (fixnum countoid))
70 (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) countoid)))
71 (declare (type bit-offset count))
74 (ecase sb!c:*backend-byte-order*
76 (ash (ldb (byte (- unit-bits count) 0) number) count))
78 (ash number (- count)))))))
80 (defun shift-towards-end (number count)
82 "Shift NUMBER by COUNT bits, adding zero bits at the ``start'' and removing
83 bits from the ``end.'' On big-endian machines this is a right-shift and
84 on little-endian machines this is a left-shift."
85 (declare (type unit number) (fixnum count))
86 (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count)))
87 (declare (type bit-offset count))
90 (ecase sb!c:*backend-byte-order*
92 (ash number (- count)))
94 (ash (ldb (byte (- unit-bits count) 0) number) count))))))
96 #!-sb-fluid (declaim (inline start-mask end-mask fix-sap-and-offset))
97 (defun start-mask (count)
99 "Produce a mask that contains 1's for the COUNT ``start'' bits and 0's for
100 the remaining ``end'' bits. Only the lower 5 bits of COUNT are significant."
101 (declare (fixnum count))
102 (shift-towards-start (1- (ash 1 unit-bits)) (- count)))
104 (defun end-mask (count)
106 "Produce a mask that contains 1's for the COUNT ``end'' bits and 0's for
107 the remaining ``start'' bits. Only the lower 5 bits of COUNT are
109 (declare (fixnum count))
110 (shift-towards-end (1- (ash 1 unit-bits)) (- count)))
112 (defun fix-sap-and-offset (sap offset)
114 "Align the SAP to a word boundary, and update the offset accordingly."
115 (declare (type system-area-pointer sap)
117 (values system-area-pointer index))
118 (let ((address (sap-int sap)))
119 (values (int-sap #!-alpha (32bit-logical-andc2 address 3)
120 #!+alpha (ash (ash address -2) 2))
121 (+ (* (logand address 3) byte-bits) offset))))
123 #!-sb-fluid (declaim (inline word-sap-ref %set-word-sap-ref))
124 (defun word-sap-ref (sap offset)
125 (declare (type system-area-pointer sap)
127 (values (unsigned-byte 32))
128 (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3)))
129 (sap-ref-32 sap (the index (ash offset 2))))
130 (defun %set-word-sap-ref (sap offset value)
131 (declare (type system-area-pointer sap)
133 (type (unsigned-byte 32) value)
134 (values (unsigned-byte 32))
135 (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
136 (setf (sap-ref-32 sap (the index (ash offset 2))) value))
138 ;;;; DO-CONSTANT-BIT-BASH
140 #!-sb-fluid (declaim (inline do-constant-bit-bash))
141 (defun do-constant-bit-bash (dst dst-offset length value dst-ref-fn dst-set-fn)
143 "Fill DST with VALUE starting at DST-OFFSET and continuing for LENGTH bits."
144 (declare (type offset dst-offset) (type unit value)
145 (type function dst-ref-fn dst-set-fn))
146 (multiple-value-bind (dst-word-offset dst-bit-offset)
147 (floor dst-offset unit-bits)
148 (declare (type word-offset dst-word-offset)
149 (type bit-offset dst-bit-offset))
150 (multiple-value-bind (words final-bits)
151 (floor (+ dst-bit-offset length) unit-bits)
152 (declare (type word-offset words) (type bit-offset final-bits))
154 (unless (zerop length)
155 (funcall dst-set-fn dst dst-word-offset
156 (if (= length unit-bits)
158 (let ((mask (shift-towards-end (start-mask length)
160 (declare (type unit mask))
162 (32bit-logical-and value mask)
164 (funcall dst-ref-fn dst dst-word-offset)
166 (let ((interior (floor (- length final-bits) unit-bits)))
167 (unless (zerop dst-bit-offset)
168 (let ((mask (end-mask (- dst-bit-offset))))
169 (declare (type unit mask))
170 (funcall dst-set-fn dst dst-word-offset
172 (32bit-logical-and value mask)
174 (funcall dst-ref-fn dst dst-word-offset)
176 (incf dst-word-offset))
177 (dotimes (i interior)
178 (funcall dst-set-fn dst dst-word-offset value)
179 (incf dst-word-offset))
180 (unless (zerop final-bits)
181 (let ((mask (start-mask final-bits)))
182 (declare (type unit mask))
183 (funcall dst-set-fn dst dst-word-offset
185 (32bit-logical-and value mask)
187 (funcall dst-ref-fn dst dst-word-offset)
191 ;;;; DO-UNARY-BIT-BASH
193 #!-sb-fluid (declaim (inline do-unary-bit-bash))
194 (defun do-unary-bit-bash (src src-offset dst dst-offset length
195 dst-ref-fn dst-set-fn src-ref-fn)
196 (declare (type offset src-offset dst-offset length)
197 (type function dst-ref-fn dst-set-fn src-ref-fn))
198 (multiple-value-bind (dst-word-offset dst-bit-offset)
199 (floor dst-offset unit-bits)
200 (declare (type word-offset dst-word-offset)
201 (type bit-offset dst-bit-offset))
202 (multiple-value-bind (src-word-offset src-bit-offset)
203 (floor src-offset unit-bits)
204 (declare (type word-offset src-word-offset)
205 (type bit-offset src-bit-offset))
207 ((<= (+ dst-bit-offset length) unit-bits)
208 ;; We are only writing one word, so it doesn't matter what order
209 ;; we do it in. But we might be reading from multiple words, so take
213 ;; Actually, we aren't even writing one word. This is really easy.
215 ((= length unit-bits)
216 ;; DST-BIT-OFFSET must be equal to zero, or we would be writing
217 ;; multiple words. If SRC-BIT-OFFSET is also zero, then we
218 ;; just transfer the single word. Otherwise we have to extract bits
219 ;; from two src words.
220 (funcall dst-set-fn dst dst-word-offset
221 (if (zerop src-bit-offset)
222 (funcall src-ref-fn src src-word-offset)
225 (funcall src-ref-fn src src-word-offset)
228 (funcall src-ref-fn src (1+ src-word-offset))
229 (- src-bit-offset))))))
231 ;; We are only writing some portion of the dst word, so we need to
232 ;; preserve the extra bits. Also, we still don't know whether we need
233 ;; one or two source words.
234 (let ((mask (shift-towards-end (start-mask length) dst-bit-offset))
235 (orig (funcall dst-ref-fn dst dst-word-offset))
237 (if (> src-bit-offset dst-bit-offset)
238 ;; The source starts further into the word than does
239 ;; the dst, so the source could extend into the next
240 ;; word. If it does, we have to merge the two words,
241 ;; and if not, we can just shift the first word.
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 the
255 ;; source, so we know the source can not extend into
256 ;; a second word (or else the dst would too, and we
257 ;; 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
270 ;; in 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 off the
281 ;; 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 (do-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 (do-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 do-unary-bit-bash))
467 (do-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 (do-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 (do-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 (do-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; so maybe SB!VM:VM-BYTE?
505 (declare (type (simple-array (unsigned-byte 8) 1) bv))
506 (declare (type sap sap))
507 (declare (type fixnum offset))
508 ;; FIXME: Actually it looks as though this, and most other calls
509 ;; to COPY-TO-SYSTEM-AREA, could be written more concisely with BYTE-BLT.
510 ;; Except that the DST-END-DST-START convention for the length is confusing.
511 ;; Perhaps I could rename BYTE-BLT to BYTE-BLIT and replace the
512 ;; DST-END argument with an N-BYTES argument?
513 (copy-to-system-area bv
514 (* sb!vm:vector-data-offset sb!vm:word-bits)
517 (* (length bv) sb!vm:byte-bits)))