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.
17 ;;;; constants and types
19 (eval-when (:compile-toplevel :load-toplevel :execute)
21 (defconstant unit-bits sb!vm:word-bits
23 "The number of bits to process at a time.")
25 (defconstant max-bits (ash most-positive-fixnum -2)
27 "The maximum number of bits that can be delt with during a single call.")
30 `(unsigned-byte ,unit-bits))
33 `(integer 0 ,max-bits))
35 (deftype bit-offset ()
36 `(integer 0 (,unit-bits)))
39 `(integer 1 (,unit-bits)))
41 (deftype word-offset ()
42 `(integer 0 (,(ceiling max-bits unit-bits))))
48 ;;; A particular implementation must offer either VOPs to translate
49 ;;; these, or DEFTRANSFORMs to convert them into something supported
50 ;;; by the architecture.
51 (macrolet ((def-frob (name &rest args)
54 (def-frob 32bit-logical-not x)
55 (def-frob 32bit-logical-and x y)
56 (def-frob 32bit-logical-or x y)
57 (def-frob 32bit-logical-xor x y)
58 (def-frob 32bit-logical-nor x y)
59 (def-frob 32bit-logical-eqv x y)
60 (def-frob 32bit-logical-nand x y)
61 (def-frob 32bit-logical-andc1 x y)
62 (def-frob 32bit-logical-andc2 x y)
63 (def-frob 32bit-logical-orc1 x y)
64 (def-frob 32bit-logical-orc2 x y))
66 (defun shift-towards-start (number countoid)
68 "Shift NUMBER by the low-order bits of COUNTOID, adding zero bits at
69 the ``end'' and removing bits from the ``start.'' On big-endian
70 machines this is a left-shift and on little-endian machines this is a
72 (declare (type unit number) (fixnum countoid))
73 (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) countoid)))
74 (declare (type bit-offset count))
77 (ecase sb!c:*backend-byte-order*
79 (ash (ldb (byte (- unit-bits count) 0) number) count))
81 (ash number (- count)))))))
83 (defun shift-towards-end (number count)
85 "Shift NUMBER by COUNT bits, adding zero bits at the ``start'' and removing
86 bits from the ``end.'' On big-endian machines this is a right-shift and
87 on little-endian machines this is a left-shift."
88 (declare (type unit number) (fixnum count))
89 (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count)))
90 (declare (type bit-offset count))
93 (ecase sb!c:*backend-byte-order*
95 (ash number (- count)))
97 (ash (ldb (byte (- unit-bits count) 0) number) count))))))
99 #!-sb-fluid (declaim (inline start-mask end-mask fix-sap-and-offset))
100 (defun start-mask (count)
102 "Produce a mask that contains 1's for the COUNT ``start'' bits and 0's for
103 the remaining ``end'' bits. Only the lower 5 bits of COUNT are significant."
104 (declare (fixnum count))
105 (shift-towards-start (1- (ash 1 unit-bits)) (- count)))
107 (defun end-mask (count)
109 "Produce a mask that contains 1's for the COUNT ``end'' bits and 0's for
110 the remaining ``start'' bits. Only the lower 5 bits of COUNT are
112 (declare (fixnum count))
113 (shift-towards-end (1- (ash 1 unit-bits)) (- count)))
115 (defun fix-sap-and-offset (sap offset)
117 "Align the SAP to a word boundary, and update the offset accordingly."
118 (declare (type system-area-pointer sap)
120 (values system-area-pointer index))
121 (let ((address (sap-int sap)))
122 (values (int-sap #!-alpha (32bit-logical-andc2 address 3)
123 #!+alpha (ash (ash address -2) 2))
124 (+ (* (logand address 3) byte-bits) offset))))
126 #!-sb-fluid (declaim (inline word-sap-ref %set-word-sap-ref))
127 (defun word-sap-ref (sap offset)
128 (declare (type system-area-pointer sap)
130 (values (unsigned-byte 32))
131 (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3)))
132 (sap-ref-32 sap (the index (ash offset 2))))
133 (defun %set-word-sap-ref (sap offset value)
134 (declare (type system-area-pointer sap)
136 (type (unsigned-byte 32) value)
137 (values (unsigned-byte 32))
138 (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
139 (setf (sap-ref-32 sap (the index (ash offset 2))) value))
141 ;;;; DO-CONSTANT-BIT-BASH
143 #!-sb-fluid (declaim (inline do-constant-bit-bash))
144 (defun do-constant-bit-bash (dst dst-offset length value dst-ref-fn dst-set-fn)
146 "Fill DST with VALUE starting at DST-OFFSET and continuing for LENGTH bits."
147 (declare (type offset dst-offset) (type unit value)
148 (type function dst-ref-fn dst-set-fn))
149 (multiple-value-bind (dst-word-offset dst-bit-offset)
150 (floor dst-offset unit-bits)
151 (declare (type word-offset dst-word-offset)
152 (type bit-offset dst-bit-offset))
153 (multiple-value-bind (words final-bits)
154 (floor (+ dst-bit-offset length) unit-bits)
155 (declare (type word-offset words) (type bit-offset final-bits))
157 (unless (zerop length)
158 (funcall dst-set-fn dst dst-word-offset
159 (if (= length unit-bits)
161 (let ((mask (shift-towards-end (start-mask length)
163 (declare (type unit mask))
165 (32bit-logical-and value mask)
167 (funcall dst-ref-fn dst dst-word-offset)
169 (let ((interior (floor (- length final-bits) unit-bits)))
170 (unless (zerop dst-bit-offset)
171 (let ((mask (end-mask (- dst-bit-offset))))
172 (declare (type unit mask))
173 (funcall dst-set-fn dst dst-word-offset
175 (32bit-logical-and value mask)
177 (funcall dst-ref-fn dst dst-word-offset)
179 (incf dst-word-offset))
180 (dotimes (i interior)
181 (funcall dst-set-fn dst dst-word-offset value)
182 (incf dst-word-offset))
183 (unless (zerop final-bits)
184 (let ((mask (start-mask final-bits)))
185 (declare (type unit mask))
186 (funcall dst-set-fn dst dst-word-offset
188 (32bit-logical-and value mask)
190 (funcall dst-ref-fn dst dst-word-offset)
194 ;;;; DO-UNARY-BIT-BASH
196 #!-sb-fluid (declaim (inline do-unary-bit-bash))
197 (defun do-unary-bit-bash (src src-offset dst dst-offset length
198 dst-ref-fn dst-set-fn src-ref-fn)
199 (declare (type offset src-offset dst-offset length)
200 (type function dst-ref-fn dst-set-fn src-ref-fn))
201 (multiple-value-bind (dst-word-offset dst-bit-offset)
202 (floor dst-offset unit-bits)
203 (declare (type word-offset dst-word-offset)
204 (type bit-offset dst-bit-offset))
205 (multiple-value-bind (src-word-offset src-bit-offset)
206 (floor src-offset unit-bits)
207 (declare (type word-offset src-word-offset)
208 (type bit-offset src-bit-offset))
210 ((<= (+ dst-bit-offset length) unit-bits)
211 ;; We are only writing one word, so it doesn't matter what order
212 ;; we do it in. But we might be reading from multiple words, so take
216 ;; Actually, we aren't even writing one word. This is real easy.
218 ((= length unit-bits)
219 ;; DST-BIT-OFFSET must be equal to zero, or we would be writing
220 ;; multiple words. If SRC-BIT-OFFSET is also zero, then we
221 ;; just transfer the single word. Otherwise we have to extract bits
222 ;; from two src words.
223 (funcall dst-set-fn dst dst-word-offset
224 (if (zerop src-bit-offset)
225 (funcall src-ref-fn src src-word-offset)
228 (funcall src-ref-fn src src-word-offset)
231 (funcall src-ref-fn src (1+ src-word-offset))
232 (- src-bit-offset))))))
234 ;; We are only writing some portion of the dst word, so we need to
235 ;; preserve the extra bits. Also, we still don't know whether we need
236 ;; one or two source words.
237 (let ((mask (shift-towards-end (start-mask length) dst-bit-offset))
238 (orig (funcall dst-ref-fn dst dst-word-offset))
240 (if (> src-bit-offset dst-bit-offset)
241 ;; The source starts further into the word than does
242 ;; the dst, so the source could extend into the next
243 ;; word. If it does, we have to merge the two words,
244 ;; and if not, we can just shift the first word.
245 (let ((src-bit-shift (- src-bit-offset dst-bit-offset)))
246 (if (> (+ src-bit-offset length) unit-bits)
249 (funcall src-ref-fn src src-word-offset)
252 (funcall src-ref-fn src (1+ src-word-offset))
255 (funcall src-ref-fn src src-word-offset)
257 ;; The dst starts further into the word than does the
258 ;; source, so we know the source can not extend into
259 ;; a second word (or else the dst would too, and we
260 ;; wouldn't be in this branch.
262 (funcall src-ref-fn src src-word-offset)
263 (- dst-bit-offset src-bit-offset)))))
264 (declare (type unit mask orig value))
265 ;; Replace the dst word.
266 (funcall dst-set-fn dst dst-word-offset
268 (32bit-logical-and value mask)
269 (32bit-logical-andc2 orig mask)))))))
270 ((= src-bit-offset dst-bit-offset)
271 ;; The source and dst are aligned, so we don't need to shift
272 ;; anything. But we have to pick the direction of the loop
273 ;; in case the source and dst are really the same thing.
274 (multiple-value-bind (words final-bits)
275 (floor (+ dst-bit-offset length) unit-bits)
276 (declare (type word-offset words) (type bit-offset final-bits))
277 (let ((interior (floor (- length final-bits) unit-bits)))
278 (declare (type word-offset interior))
280 ((<= dst-offset src-offset)
281 ;; We need to loop from left to right
282 (unless (zerop dst-bit-offset)
283 ;; We are only writing part of the first word, so mask off the
284 ;; bits we want to preserve.
285 (let ((mask (end-mask (- dst-bit-offset)))
286 (orig (funcall dst-ref-fn dst dst-word-offset))
287 (value (funcall src-ref-fn src src-word-offset)))
288 (declare (type unit mask orig value))
289 (funcall dst-set-fn dst dst-word-offset
290 (32bit-logical-or (32bit-logical-and value mask)
291 (32bit-logical-andc2 orig mask))))
292 (incf src-word-offset)
293 (incf dst-word-offset))
294 ;; Just copy the interior words.
295 (dotimes (i interior)
296 (funcall dst-set-fn dst dst-word-offset
297 (funcall src-ref-fn src src-word-offset))
298 (incf src-word-offset)
299 (incf dst-word-offset))
300 (unless (zerop final-bits)
301 ;; We are only writing part of the last word.
302 (let ((mask (start-mask final-bits))
303 (orig (funcall dst-ref-fn dst dst-word-offset))
304 (value (funcall src-ref-fn src src-word-offset)))
305 (declare (type unit mask orig value))
306 (funcall dst-set-fn dst dst-word-offset
308 (32bit-logical-and value mask)
309 (32bit-logical-andc2 orig mask))))))
311 ;; We need to loop from right to left.
312 (incf dst-word-offset words)
313 (incf src-word-offset words)
314 (unless (zerop final-bits)
315 (let ((mask (start-mask final-bits))
316 (orig (funcall dst-ref-fn dst dst-word-offset))
317 (value (funcall src-ref-fn src src-word-offset)))
318 (declare (type unit mask orig value))
319 (funcall dst-set-fn dst dst-word-offset
321 (32bit-logical-and value mask)
322 (32bit-logical-andc2 orig mask)))))
323 (dotimes (i interior)
324 (decf src-word-offset)
325 (decf dst-word-offset)
326 (funcall dst-set-fn dst dst-word-offset
327 (funcall src-ref-fn src src-word-offset)))
328 (unless (zerop dst-bit-offset)
329 (decf src-word-offset)
330 (decf dst-word-offset)
331 (let ((mask (end-mask (- dst-bit-offset)))
332 (orig (funcall dst-ref-fn dst dst-word-offset))
333 (value (funcall src-ref-fn src src-word-offset)))
334 (declare (type unit mask orig value))
335 (funcall dst-set-fn dst dst-word-offset
337 (32bit-logical-and value mask)
338 (32bit-logical-andc2 orig mask))))))))))
340 ;; They aren't aligned.
341 (multiple-value-bind (words final-bits)
342 (floor (+ dst-bit-offset length) unit-bits)
343 (declare (type word-offset words) (type bit-offset final-bits))
344 (let ((src-shift (mod (- src-bit-offset dst-bit-offset) unit-bits))
345 (interior (floor (- length final-bits) unit-bits)))
346 (declare (type bit-offset src-shift)
347 (type word-offset interior))
349 ((<= dst-offset src-offset)
350 ;; We need to loop from left to right
352 (next (funcall src-ref-fn src src-word-offset)))
353 (declare (type unit prev next))
354 (flet ((get-next-src ()
356 (setf next (funcall src-ref-fn src
357 (incf src-word-offset)))))
358 (declare (inline get-next-src))
359 (unless (zerop dst-bit-offset)
360 (when (> src-bit-offset dst-bit-offset)
362 (let ((mask (end-mask (- dst-bit-offset)))
363 (orig (funcall dst-ref-fn dst dst-word-offset))
364 (value (32bit-logical-or
365 (shift-towards-start prev src-shift)
366 (shift-towards-end next (- src-shift)))))
367 (declare (type unit mask orig value))
368 (funcall dst-set-fn dst dst-word-offset
370 (32bit-logical-and value mask)
371 (32bit-logical-andc2 orig mask)))
372 (incf dst-word-offset)))
373 (dotimes (i interior)
375 (let ((value (32bit-logical-or
376 (shift-towards-end next (- src-shift))
377 (shift-towards-start prev src-shift))))
378 (declare (type unit value))
379 (funcall dst-set-fn dst dst-word-offset value)
380 (incf dst-word-offset)))
381 (unless (zerop final-bits)
383 (if (> (+ final-bits src-shift) unit-bits)
387 (shift-towards-end next (- src-shift))
388 (shift-towards-start prev src-shift)))
389 (shift-towards-start next src-shift)))
390 (mask (start-mask final-bits))
391 (orig (funcall dst-ref-fn dst dst-word-offset)))
392 (declare (type unit mask orig value))
393 (funcall dst-set-fn dst dst-word-offset
395 (32bit-logical-and value mask)
396 (32bit-logical-andc2 orig mask))))))))
398 ;; We need to loop from right to left.
399 (incf dst-word-offset words)
400 (incf src-word-offset
401 (1- (ceiling (+ src-bit-offset length) unit-bits)))
403 (prev (funcall src-ref-fn src src-word-offset)))
404 (declare (type unit prev next))
405 (flet ((get-next-src ()
407 (setf prev (funcall src-ref-fn src
408 (decf src-word-offset)))))
409 (declare (inline get-next-src))
410 (unless (zerop final-bits)
411 (when (> final-bits (- unit-bits src-shift))
413 (let ((value (32bit-logical-or
414 (shift-towards-end next (- src-shift))
415 (shift-towards-start prev src-shift)))
416 (mask (start-mask final-bits))
417 (orig (funcall dst-ref-fn dst dst-word-offset)))
418 (declare (type unit mask orig value))
419 (funcall dst-set-fn dst dst-word-offset
421 (32bit-logical-and value mask)
422 (32bit-logical-andc2 orig mask)))))
423 (decf dst-word-offset)
424 (dotimes (i interior)
426 (let ((value (32bit-logical-or
427 (shift-towards-end next (- src-shift))
428 (shift-towards-start prev src-shift))))
429 (declare (type unit value))
430 (funcall dst-set-fn dst dst-word-offset value)
431 (decf dst-word-offset)))
432 (unless (zerop dst-bit-offset)
433 (if (> src-bit-offset dst-bit-offset)
435 (setf next prev prev 0))
436 (let ((mask (end-mask (- dst-bit-offset)))
437 (orig (funcall dst-ref-fn dst dst-word-offset))
438 (value (32bit-logical-or
439 (shift-towards-start prev src-shift)
440 (shift-towards-end next (- src-shift)))))
441 (declare (type unit mask orig value))
442 (funcall dst-set-fn dst dst-word-offset
444 (32bit-logical-and value mask)
445 (32bit-logical-andc2 orig mask)))))))))))))))
448 ;;;; the actual bashers
450 (defun bit-bash-fill (value dst dst-offset length)
451 (declare (type unit value) (type offset dst-offset length))
453 (declare (optimize (speed 3) (safety 0)))
454 (do-constant-bit-bash dst dst-offset length value
455 #'%raw-bits #'%set-raw-bits)))
457 (defun system-area-fill (value dst dst-offset length)
458 (declare (type unit value) (type offset dst-offset length))
460 (declare (optimize (speed 3) (safety 0)))
461 (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
462 (do-constant-bit-bash dst dst-offset length value
463 #'word-sap-ref #'%set-word-sap-ref))))
465 (defun bit-bash-copy (src src-offset dst dst-offset length)
466 (declare (type offset src-offset dst-offset length))
468 (declare (optimize (speed 3) (safety 0))
469 (inline do-unary-bit-bash))
470 (do-unary-bit-bash src src-offset dst dst-offset length
471 #'%raw-bits #'%set-raw-bits #'%raw-bits)))
473 (defun system-area-copy (src src-offset dst dst-offset length)
474 (declare (type offset src-offset dst-offset length))
476 (declare (optimize (speed 3) (safety 0)))
477 (multiple-value-bind (src src-offset) (fix-sap-and-offset src src-offset)
478 (declare (type system-area-pointer src))
479 (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
480 (declare (type system-area-pointer dst))
481 (do-unary-bit-bash src src-offset dst dst-offset length
482 #'word-sap-ref #'%set-word-sap-ref
485 (defun copy-to-system-area (src src-offset dst dst-offset length)
486 (declare (type offset src-offset dst-offset length))
488 (declare (optimize (speed 3) (safety 0)))
489 (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
490 (do-unary-bit-bash src src-offset dst dst-offset length
491 #'word-sap-ref #'%set-word-sap-ref #'%raw-bits))))
493 (defun copy-from-system-area (src src-offset dst dst-offset length)
494 (declare (type offset src-offset dst-offset length))
496 (declare (optimize (speed 3) (safety 0)))
497 (multiple-value-bind (src src-offset) (fix-sap-and-offset src src-offset)
498 (do-unary-bit-bash src src-offset dst dst-offset length
499 #'%raw-bits #'%set-raw-bits #'word-sap-ref))))
501 ;;; a common idiom for calling COPY-TO-SYSTEM-AREA
503 ;;; Copy the entire contents of the vector V to memory starting at SAP+OFFSET.
504 (defun copy-byte-vector-to-system-area (bv sap &optional (offset 0))
505 ;; FIXME: There should be a type like SB!VM:BYTE so that we can write this
506 ;; type as (SIMPLE-ARRAY SB!VM:BYTE 1). Except BYTE is an external symbol of
507 ;; package CL; so maybe SB!VM:VM-BYTE?
508 (declare (type (simple-array (unsigned-byte 8) 1) bv))
509 (declare (type sap sap))
510 (declare (type fixnum offset))
511 ;; FIXME: Actually it looks as though this, and most other calls
512 ;; to COPY-TO-SYSTEM-AREA, could be written more concisely with BYTE-BLT.
513 ;; Except that the DST-END-DST-START convention for the length is confusing.
514 ;; Perhaps I could rename BYTE-BLT to BYTE-BLIT and replace the
515 ;; DST-END argument with an N-BYTES argument?
516 (copy-to-system-area bv
517 (* sb!vm:vector-data-offset sb!vm:word-bits)
520 (* (length bv) sb!vm:byte-bits)))