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 sb!vm: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))
22 (eval-when (:compile-toplevel :load-toplevel :execute)
24 ;;; FIXME: Do we really need EVAL-WHEN around the DEFTYPEs?
26 `(unsigned-byte ,unit-bits))
29 `(integer 0 ,max-bits))
31 (deftype bit-offset ()
32 `(integer 0 (,unit-bits)))
35 `(integer 1 (,unit-bits)))
37 (deftype word-offset ()
38 `(integer 0 (,(ceiling max-bits unit-bits))))
44 ;;; A particular implementation must offer either VOPs to translate
45 ;;; these, or DEFTRANSFORMs to convert them into something supported
46 ;;; by the architecture.
47 (macrolet ((def-frob (name &rest args)
50 (def-frob 32bit-logical-not x)
51 (def-frob 32bit-logical-and x y)
52 (def-frob 32bit-logical-or x y)
53 (def-frob 32bit-logical-xor x y)
54 (def-frob 32bit-logical-nor x y)
55 (def-frob 32bit-logical-eqv x y)
56 (def-frob 32bit-logical-nand x y)
57 (def-frob 32bit-logical-andc1 x y)
58 (def-frob 32bit-logical-andc2 x y)
59 (def-frob 32bit-logical-orc1 x y)
60 (def-frob 32bit-logical-orc2 x y))
62 ;;; Shift NUMBER by the low-order bits of COUNTOID, adding zero bits
63 ;;; at the "end" and removing bits from the "start". On big-endian
64 ;;; machines this is a left-shift and on little-endian machines this
66 (defun shift-towards-start (number countoid)
67 (declare (type unit number) (fixnum countoid))
68 (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) countoid)))
69 (declare (type bit-offset count))
72 (ecase sb!c:*backend-byte-order*
74 (ash (ldb (byte (- unit-bits count) 0) number) count))
76 (ash number (- count)))))))
78 ;;; Shift NUMBER by COUNT bits, adding zero bits at the "start" and
79 ;;; removing bits from the "end". On big-endian machines this is a
80 ;;; right-shift and on little-endian machines this is a left-shift.
81 (defun shift-towards-end (number count)
82 (declare (type unit number) (fixnum count))
83 (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count)))
84 (declare (type bit-offset count))
87 (ecase sb!c:*backend-byte-order*
89 (ash number (- count)))
91 (ash (ldb (byte (- unit-bits count) 0) number) count))))))
93 #!-sb-fluid (declaim (inline start-mask end-mask fix-sap-and-offset))
95 ;;; Produce a mask that contains 1's for the COUNT "start" bits and
96 ;;; 0's for the remaining "end" bits. Only the lower 5 bits of COUNT
97 ;;; are significant (KLUDGE: because of hardwired implicit dependence
98 ;;; on 32-bit word size -- WHN 2001-03-19).
99 (defun start-mask (count)
100 (declare (fixnum count))
101 (shift-towards-start (1- (ash 1 unit-bits)) (- count)))
103 ;;; Produce a mask that contains 1's for the COUNT "end" bits and 0's
104 ;;; for the remaining "start" bits. Only the lower 5 bits of COUNT are
105 ;;; significant (KLUDGE: because of hardwired implicit dependence on
106 ;;; 32-bit word size -- WHN 2001-03-19).
107 (defun end-mask (count)
108 (declare (fixnum count))
109 (shift-towards-end (1- (ash 1 unit-bits)) (- count)))
111 ;;; Align the SAP to a word boundary, and update the offset accordingly.
112 (defun fix-sap-and-offset (sap offset)
113 (declare (type system-area-pointer sap)
115 (values system-area-pointer index))
116 (let ((address (sap-int sap)))
117 (values (int-sap #!-alpha (32bit-logical-andc2 address 3)
118 #!+alpha (ash (ash address -2) 2))
119 (+ (* (logand address 3) byte-bits) offset))))
121 #!-sb-fluid (declaim (inline word-sap-ref %set-word-sap-ref))
122 (defun word-sap-ref (sap offset)
123 (declare (type system-area-pointer sap)
125 (values (unsigned-byte 32))
126 (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3)))
127 (sap-ref-32 sap (the index (ash offset 2))))
128 (defun %set-word-sap-ref (sap offset value)
129 (declare (type system-area-pointer sap)
131 (type (unsigned-byte 32) value)
132 (values (unsigned-byte 32))
133 (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
134 (setf (sap-ref-32 sap (the index (ash offset 2))) value))
136 ;;;; DO-CONSTANT-BIT-BASH
138 ;;; Fill DST with VALUE starting at DST-OFFSET and continuing for
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)
142 (declare (type offset dst-offset) (type unit value)
143 (type function dst-ref-fn dst-set-fn))
144 (multiple-value-bind (dst-word-offset dst-bit-offset)
145 (floor dst-offset unit-bits)
146 (declare (type word-offset dst-word-offset)
147 (type bit-offset dst-bit-offset))
148 (multiple-value-bind (words final-bits)
149 (floor (+ dst-bit-offset length) unit-bits)
150 (declare (type word-offset words) (type bit-offset final-bits))
152 (unless (zerop length)
153 (funcall dst-set-fn dst dst-word-offset
154 (if (= length unit-bits)
156 (let ((mask (shift-towards-end (start-mask length)
158 (declare (type unit mask))
160 (32bit-logical-and value mask)
162 (funcall dst-ref-fn dst dst-word-offset)
164 (let ((interior (floor (- length final-bits) unit-bits)))
165 (unless (zerop dst-bit-offset)
166 (let ((mask (end-mask (- dst-bit-offset))))
167 (declare (type unit mask))
168 (funcall dst-set-fn dst dst-word-offset
170 (32bit-logical-and value mask)
172 (funcall dst-ref-fn dst dst-word-offset)
174 (incf dst-word-offset))
175 (dotimes (i interior)
176 (funcall dst-set-fn dst dst-word-offset value)
177 (incf dst-word-offset))
178 (unless (zerop final-bits)
179 (let ((mask (start-mask final-bits)))
180 (declare (type unit mask))
181 (funcall dst-set-fn dst dst-word-offset
183 (32bit-logical-and value mask)
185 (funcall dst-ref-fn dst dst-word-offset)
189 ;;;; DO-UNARY-BIT-BASH
191 #!-sb-fluid (declaim (inline do-unary-bit-bash))
192 (defun do-unary-bit-bash (src src-offset dst dst-offset length
193 dst-ref-fn dst-set-fn src-ref-fn)
194 (declare (type offset src-offset dst-offset length)
195 (type function dst-ref-fn dst-set-fn src-ref-fn))
196 (multiple-value-bind (dst-word-offset dst-bit-offset)
197 (floor dst-offset unit-bits)
198 (declare (type word-offset dst-word-offset)
199 (type bit-offset dst-bit-offset))
200 (multiple-value-bind (src-word-offset src-bit-offset)
201 (floor src-offset unit-bits)
202 (declare (type word-offset src-word-offset)
203 (type bit-offset src-bit-offset))
205 ((<= (+ dst-bit-offset length) unit-bits)
206 ;; We are only writing one word, so it doesn't matter what order
207 ;; we do it in. But we might be reading from multiple words, so take
211 ;; Actually, we aren't even writing one word. This is really easy.
213 ((= length unit-bits)
214 ;; DST-BIT-OFFSET must be equal to zero, or we would be writing
215 ;; multiple words. If SRC-BIT-OFFSET is also zero, then we
216 ;; just transfer the single word. Otherwise we have to extract bits
217 ;; from two src words.
218 (funcall dst-set-fn dst dst-word-offset
219 (if (zerop src-bit-offset)
220 (funcall src-ref-fn src src-word-offset)
223 (funcall src-ref-fn src src-word-offset)
226 (funcall src-ref-fn src (1+ src-word-offset))
227 (- src-bit-offset))))))
229 ;; We are only writing some portion of the dst word, so we need to
230 ;; preserve the extra bits. Also, we still don't know whether we need
231 ;; one or two source words.
232 (let ((mask (shift-towards-end (start-mask length) dst-bit-offset))
233 (orig (funcall dst-ref-fn dst dst-word-offset))
235 (if (> src-bit-offset dst-bit-offset)
236 ;; The source starts further into the word than does
237 ;; the dst, so the source could extend into the next
238 ;; word. If it does, we have to merge the two words,
239 ;; and if not, we can just shift the first word.
240 (let ((src-bit-shift (- src-bit-offset dst-bit-offset)))
241 (if (> (+ src-bit-offset length) unit-bits)
244 (funcall src-ref-fn src src-word-offset)
247 (funcall src-ref-fn src (1+ src-word-offset))
250 (funcall src-ref-fn src src-word-offset)
252 ;; The dst starts further into the word than does the
253 ;; source, so we know the source can not extend into
254 ;; a second word (or else the dst would too, and we
255 ;; wouldn't be in this branch.
257 (funcall src-ref-fn src src-word-offset)
258 (- dst-bit-offset src-bit-offset)))))
259 (declare (type unit mask orig value))
260 ;; Replace the dst word.
261 (funcall dst-set-fn dst dst-word-offset
263 (32bit-logical-and value mask)
264 (32bit-logical-andc2 orig mask)))))))
265 ((= src-bit-offset dst-bit-offset)
266 ;; The source and dst are aligned, so we don't need to shift
267 ;; anything. But we have to pick the direction of the loop
268 ;; in case the source and dst are really the same thing.
269 (multiple-value-bind (words final-bits)
270 (floor (+ dst-bit-offset length) unit-bits)
271 (declare (type word-offset words) (type bit-offset final-bits))
272 (let ((interior (floor (- length final-bits) unit-bits)))
273 (declare (type word-offset interior))
275 ((<= dst-offset src-offset)
276 ;; We need to loop from left to right
277 (unless (zerop dst-bit-offset)
278 ;; We are only writing part of the first word, so mask off the
279 ;; bits we want to preserve.
280 (let ((mask (end-mask (- dst-bit-offset)))
281 (orig (funcall dst-ref-fn dst dst-word-offset))
282 (value (funcall src-ref-fn src src-word-offset)))
283 (declare (type unit mask orig value))
284 (funcall dst-set-fn dst dst-word-offset
285 (32bit-logical-or (32bit-logical-and value mask)
286 (32bit-logical-andc2 orig mask))))
287 (incf src-word-offset)
288 (incf dst-word-offset))
289 ;; Just copy the interior words.
290 (dotimes (i interior)
291 (funcall dst-set-fn dst dst-word-offset
292 (funcall src-ref-fn src src-word-offset))
293 (incf src-word-offset)
294 (incf dst-word-offset))
295 (unless (zerop final-bits)
296 ;; We are only writing part of the last word.
297 (let ((mask (start-mask final-bits))
298 (orig (funcall dst-ref-fn dst dst-word-offset))
299 (value (funcall src-ref-fn src src-word-offset)))
300 (declare (type unit mask orig value))
301 (funcall dst-set-fn dst dst-word-offset
303 (32bit-logical-and value mask)
304 (32bit-logical-andc2 orig mask))))))
306 ;; We need to loop from right to left.
307 (incf dst-word-offset words)
308 (incf src-word-offset words)
309 (unless (zerop final-bits)
310 (let ((mask (start-mask final-bits))
311 (orig (funcall dst-ref-fn dst dst-word-offset))
312 (value (funcall src-ref-fn src src-word-offset)))
313 (declare (type unit mask orig value))
314 (funcall dst-set-fn dst dst-word-offset
316 (32bit-logical-and value mask)
317 (32bit-logical-andc2 orig mask)))))
318 (dotimes (i interior)
319 (decf src-word-offset)
320 (decf dst-word-offset)
321 (funcall dst-set-fn dst dst-word-offset
322 (funcall src-ref-fn src src-word-offset)))
323 (unless (zerop dst-bit-offset)
324 (decf src-word-offset)
325 (decf dst-word-offset)
326 (let ((mask (end-mask (- dst-bit-offset)))
327 (orig (funcall dst-ref-fn dst dst-word-offset))
328 (value (funcall src-ref-fn src src-word-offset)))
329 (declare (type unit mask orig value))
330 (funcall dst-set-fn dst dst-word-offset
332 (32bit-logical-and value mask)
333 (32bit-logical-andc2 orig mask))))))))))
335 ;; They aren't aligned.
336 (multiple-value-bind (words final-bits)
337 (floor (+ dst-bit-offset length) unit-bits)
338 (declare (type word-offset words) (type bit-offset final-bits))
339 (let ((src-shift (mod (- src-bit-offset dst-bit-offset) unit-bits))
340 (interior (floor (- length final-bits) unit-bits)))
341 (declare (type bit-offset src-shift)
342 (type word-offset interior))
344 ((<= dst-offset src-offset)
345 ;; We need to loop from left to right
347 (next (funcall src-ref-fn src src-word-offset)))
348 (declare (type unit prev next))
349 (flet ((get-next-src ()
351 (setf next (funcall src-ref-fn src
352 (incf src-word-offset)))))
353 (declare (inline get-next-src))
354 (unless (zerop dst-bit-offset)
355 (when (> src-bit-offset dst-bit-offset)
357 (let ((mask (end-mask (- dst-bit-offset)))
358 (orig (funcall dst-ref-fn dst dst-word-offset))
359 (value (32bit-logical-or
360 (shift-towards-start prev src-shift)
361 (shift-towards-end next (- src-shift)))))
362 (declare (type unit mask orig value))
363 (funcall dst-set-fn dst dst-word-offset
365 (32bit-logical-and value mask)
366 (32bit-logical-andc2 orig mask)))
367 (incf dst-word-offset)))
368 (dotimes (i interior)
370 (let ((value (32bit-logical-or
371 (shift-towards-end next (- src-shift))
372 (shift-towards-start prev src-shift))))
373 (declare (type unit value))
374 (funcall dst-set-fn dst dst-word-offset value)
375 (incf dst-word-offset)))
376 (unless (zerop final-bits)
378 (if (> (+ final-bits src-shift) unit-bits)
382 (shift-towards-end next (- src-shift))
383 (shift-towards-start prev src-shift)))
384 (shift-towards-start next src-shift)))
385 (mask (start-mask final-bits))
386 (orig (funcall dst-ref-fn dst dst-word-offset)))
387 (declare (type unit mask orig value))
388 (funcall dst-set-fn dst dst-word-offset
390 (32bit-logical-and value mask)
391 (32bit-logical-andc2 orig mask))))))))
393 ;; We need to loop from right to left.
394 (incf dst-word-offset words)
395 (incf src-word-offset
396 (1- (ceiling (+ src-bit-offset length) unit-bits)))
398 (prev (funcall src-ref-fn src src-word-offset)))
399 (declare (type unit prev next))
400 (flet ((get-next-src ()
402 (setf prev (funcall src-ref-fn src
403 (decf src-word-offset)))))
404 (declare (inline get-next-src))
405 (unless (zerop final-bits)
406 (when (> final-bits (- unit-bits src-shift))
408 (let ((value (32bit-logical-or
409 (shift-towards-end next (- src-shift))
410 (shift-towards-start prev src-shift)))
411 (mask (start-mask final-bits))
412 (orig (funcall dst-ref-fn dst dst-word-offset)))
413 (declare (type unit mask orig value))
414 (funcall dst-set-fn dst dst-word-offset
416 (32bit-logical-and value mask)
417 (32bit-logical-andc2 orig mask)))))
418 (decf dst-word-offset)
419 (dotimes (i interior)
421 (let ((value (32bit-logical-or
422 (shift-towards-end next (- src-shift))
423 (shift-towards-start prev src-shift))))
424 (declare (type unit value))
425 (funcall dst-set-fn dst dst-word-offset value)
426 (decf dst-word-offset)))
427 (unless (zerop dst-bit-offset)
428 (if (> src-bit-offset dst-bit-offset)
430 (setf next prev prev 0))
431 (let ((mask (end-mask (- dst-bit-offset)))
432 (orig (funcall dst-ref-fn dst dst-word-offset))
433 (value (32bit-logical-or
434 (shift-towards-start prev src-shift)
435 (shift-towards-end next (- src-shift)))))
436 (declare (type unit mask orig value))
437 (funcall dst-set-fn dst dst-word-offset
439 (32bit-logical-and value mask)
440 (32bit-logical-andc2 orig mask)))))))))))))))
443 ;;;; the actual bashers
445 (defun bit-bash-fill (value dst dst-offset length)
446 (declare (type unit value) (type offset dst-offset length))
448 (declare (optimize (speed 3) (safety 0)))
449 (do-constant-bit-bash dst dst-offset length value
450 #'%raw-bits #'%set-raw-bits)))
452 (defun system-area-fill (value dst dst-offset length)
453 (declare (type unit value) (type offset dst-offset length))
455 (declare (optimize (speed 3) (safety 0)))
456 (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
457 (do-constant-bit-bash dst dst-offset length value
458 #'word-sap-ref #'%set-word-sap-ref))))
460 (defun bit-bash-copy (src src-offset dst dst-offset length)
461 (declare (type offset src-offset dst-offset length))
463 (declare (optimize (speed 3) (safety 0))
464 (inline do-unary-bit-bash))
465 (do-unary-bit-bash src src-offset dst dst-offset length
466 #'%raw-bits #'%set-raw-bits #'%raw-bits)))
468 (defun system-area-copy (src src-offset dst dst-offset length)
469 (declare (type offset src-offset dst-offset length))
471 (declare (optimize (speed 3) (safety 0)))
472 (multiple-value-bind (src src-offset) (fix-sap-and-offset src src-offset)
473 (declare (type system-area-pointer src))
474 (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
475 (declare (type system-area-pointer dst))
476 (do-unary-bit-bash src src-offset dst dst-offset length
477 #'word-sap-ref #'%set-word-sap-ref
480 (defun copy-to-system-area (src src-offset dst dst-offset length)
481 (declare (type offset src-offset dst-offset length))
483 (declare (optimize (speed 3) (safety 0)))
484 (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
485 (do-unary-bit-bash src src-offset dst dst-offset length
486 #'word-sap-ref #'%set-word-sap-ref #'%raw-bits))))
488 (defun copy-from-system-area (src src-offset dst dst-offset length)
489 (declare (type offset src-offset dst-offset length))
491 (declare (optimize (speed 3) (safety 0)))
492 (multiple-value-bind (src src-offset) (fix-sap-and-offset src src-offset)
493 (do-unary-bit-bash src src-offset dst dst-offset length
494 #'%raw-bits #'%set-raw-bits #'word-sap-ref))))
496 ;;; a common idiom for calling COPY-TO-SYSTEM-AREA
498 ;;; Copy the entire contents of the vector V to memory starting at SAP+OFFSET.
499 (defun copy-byte-vector-to-system-area (bv sap &optional (offset 0))
500 ;; FIXME: There should be a type like SB!VM:BYTE so that we can write this
501 ;; type as (SIMPLE-ARRAY SB!VM:BYTE 1). Except BYTE is an external symbol of
502 ;; package CL; so maybe SB!VM:VM-BYTE?
503 (declare (type (simple-array (unsigned-byte 8) 1) bv))
504 (declare (type sap sap))
505 (declare (type fixnum offset))
506 ;; FIXME: Actually it looks as though this, and most other calls
507 ;; to COPY-TO-SYSTEM-AREA, could be written more concisely with BYTE-BLT.
508 ;; Except that the DST-END-DST-START convention for the length is confusing.
509 ;; Perhaps I could rename BYTE-BLT to BYTE-BLIT and replace the
510 ;; DST-END argument with an N-BYTES argument?
511 (copy-to-system-area bv
512 (* sb!vm:vector-data-offset sb!vm:word-bits)
515 (* (length bv) sb!vm:byte-bits)))