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))
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-frob (name &rest args)
45 (def-frob 32bit-logical-not x)
46 (def-frob 32bit-logical-and x y)
47 (def-frob 32bit-logical-or x y)
48 (def-frob 32bit-logical-xor x y)
49 (def-frob 32bit-logical-nor x y)
50 (def-frob 32bit-logical-eqv x y)
51 (def-frob 32bit-logical-nand x y)
52 (def-frob 32bit-logical-andc1 x y)
53 (def-frob 32bit-logical-andc2 x y)
54 (def-frob 32bit-logical-orc1 x y)
55 (def-frob 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) 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 ;;;; DO-CONSTANT-BIT-BASH
133 ;;; Fill DST with VALUE starting at DST-OFFSET and continuing for
135 #!-sb-fluid (declaim (inline do-constant-bit-bash))
136 (defun do-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)
184 ;;;; DO-UNARY-BIT-BASH
186 #!-sb-fluid (declaim (inline do-unary-bit-bash))
187 (defun do-unary-bit-bash (src src-offset dst dst-offset length
188 dst-ref-fn dst-set-fn src-ref-fn)
189 (declare (type offset src-offset dst-offset length)
190 (type function dst-ref-fn dst-set-fn src-ref-fn))
191 (multiple-value-bind (dst-word-offset dst-bit-offset)
192 (floor dst-offset unit-bits)
193 (declare (type word-offset dst-word-offset)
194 (type bit-offset dst-bit-offset))
195 (multiple-value-bind (src-word-offset src-bit-offset)
196 (floor src-offset unit-bits)
197 (declare (type word-offset src-word-offset)
198 (type bit-offset src-bit-offset))
200 ((<= (+ dst-bit-offset length) unit-bits)
201 ;; We are only writing one word, so it doesn't matter what order
202 ;; we do it in. But we might be reading from multiple words, so take
206 ;; Actually, we aren't even writing one word. This is really easy.
208 ((= length unit-bits)
209 ;; DST-BIT-OFFSET must be equal to zero, or we would be writing
210 ;; multiple words. If SRC-BIT-OFFSET is also zero, then we
211 ;; just transfer the single word. Otherwise we have to extract bits
212 ;; from two src words.
213 (funcall dst-set-fn dst dst-word-offset
214 (if (zerop src-bit-offset)
215 (funcall src-ref-fn src src-word-offset)
218 (funcall src-ref-fn src src-word-offset)
221 (funcall src-ref-fn src (1+ src-word-offset))
222 (- src-bit-offset))))))
224 ;; We are only writing some portion of the dst word, so we need to
225 ;; preserve the extra bits. Also, we still don't know whether we need
226 ;; one or two source words.
227 (let ((mask (shift-towards-end (start-mask length) dst-bit-offset))
228 (orig (funcall dst-ref-fn dst dst-word-offset))
230 (if (> src-bit-offset dst-bit-offset)
231 ;; The source starts further into the word than does
232 ;; the dst, so the source could extend into the next
233 ;; word. If it does, we have to merge the two words,
234 ;; and if not, we can just shift the first word.
235 (let ((src-bit-shift (- src-bit-offset dst-bit-offset)))
236 (if (> (+ src-bit-offset length) unit-bits)
239 (funcall src-ref-fn src src-word-offset)
242 (funcall src-ref-fn src (1+ src-word-offset))
245 (funcall src-ref-fn src src-word-offset)
247 ;; The dst starts further into the word than does the
248 ;; source, so we know the source can not extend into
249 ;; a second word (or else the dst would too, and we
250 ;; wouldn't be in this branch.
252 (funcall src-ref-fn src src-word-offset)
253 (- dst-bit-offset src-bit-offset)))))
254 (declare (type unit mask orig value))
255 ;; Replace the dst word.
256 (funcall dst-set-fn dst dst-word-offset
258 (32bit-logical-and value mask)
259 (32bit-logical-andc2 orig mask)))))))
260 ((= src-bit-offset dst-bit-offset)
261 ;; The source and dst are aligned, so we don't need to shift
262 ;; anything. But we have to pick the direction of the loop
263 ;; in case the source and dst are really the same thing.
264 (multiple-value-bind (words final-bits)
265 (floor (+ dst-bit-offset length) unit-bits)
266 (declare (type word-offset words) (type bit-offset final-bits))
267 (let ((interior (floor (- length final-bits) unit-bits)))
268 (declare (type word-offset interior))
270 ((<= dst-offset src-offset)
271 ;; We need to loop from left to right
272 (unless (zerop dst-bit-offset)
273 ;; We are only writing part of the first word, so mask off the
274 ;; bits we want to preserve.
275 (let ((mask (end-mask (- dst-bit-offset)))
276 (orig (funcall dst-ref-fn dst dst-word-offset))
277 (value (funcall src-ref-fn src src-word-offset)))
278 (declare (type unit mask orig value))
279 (funcall dst-set-fn dst dst-word-offset
280 (32bit-logical-or (32bit-logical-and value mask)
281 (32bit-logical-andc2 orig mask))))
282 (incf src-word-offset)
283 (incf dst-word-offset))
284 ;; Just copy the interior words.
285 (dotimes (i interior)
286 (funcall dst-set-fn dst dst-word-offset
287 (funcall src-ref-fn src src-word-offset))
288 (incf src-word-offset)
289 (incf dst-word-offset))
290 (unless (zerop final-bits)
291 ;; We are only writing part of the last word.
292 (let ((mask (start-mask final-bits))
293 (orig (funcall dst-ref-fn dst dst-word-offset))
294 (value (funcall src-ref-fn src src-word-offset)))
295 (declare (type unit mask orig value))
296 (funcall dst-set-fn dst dst-word-offset
298 (32bit-logical-and value mask)
299 (32bit-logical-andc2 orig mask))))))
301 ;; We need to loop from right to left.
302 (incf dst-word-offset words)
303 (incf src-word-offset words)
304 (unless (zerop final-bits)
305 (let ((mask (start-mask final-bits))
306 (orig (funcall dst-ref-fn dst dst-word-offset))
307 (value (funcall src-ref-fn src src-word-offset)))
308 (declare (type unit mask orig value))
309 (funcall dst-set-fn dst dst-word-offset
311 (32bit-logical-and value mask)
312 (32bit-logical-andc2 orig mask)))))
313 (dotimes (i interior)
314 (decf src-word-offset)
315 (decf dst-word-offset)
316 (funcall dst-set-fn dst dst-word-offset
317 (funcall src-ref-fn src src-word-offset)))
318 (unless (zerop dst-bit-offset)
319 (decf src-word-offset)
320 (decf dst-word-offset)
321 (let ((mask (end-mask (- dst-bit-offset)))
322 (orig (funcall dst-ref-fn dst dst-word-offset))
323 (value (funcall src-ref-fn src src-word-offset)))
324 (declare (type unit mask orig value))
325 (funcall dst-set-fn dst dst-word-offset
327 (32bit-logical-and value mask)
328 (32bit-logical-andc2 orig mask))))))))))
330 ;; They aren't aligned.
331 (multiple-value-bind (words final-bits)
332 (floor (+ dst-bit-offset length) unit-bits)
333 (declare (type word-offset words) (type bit-offset final-bits))
334 (let ((src-shift (mod (- src-bit-offset dst-bit-offset) unit-bits))
335 (interior (floor (- length final-bits) unit-bits)))
336 (declare (type bit-offset src-shift)
337 (type word-offset interior))
339 ((<= dst-offset src-offset)
340 ;; We need to loop from left to right
342 (next (funcall src-ref-fn src src-word-offset)))
343 (declare (type unit prev next))
344 (flet ((get-next-src ()
346 (setf next (funcall src-ref-fn src
347 (incf src-word-offset)))))
348 (declare (inline get-next-src))
349 (unless (zerop dst-bit-offset)
350 (when (> src-bit-offset dst-bit-offset)
352 (let ((mask (end-mask (- dst-bit-offset)))
353 (orig (funcall dst-ref-fn dst dst-word-offset))
354 (value (32bit-logical-or
355 (shift-towards-start prev src-shift)
356 (shift-towards-end next (- src-shift)))))
357 (declare (type unit mask orig value))
358 (funcall dst-set-fn dst dst-word-offset
360 (32bit-logical-and value mask)
361 (32bit-logical-andc2 orig mask)))
362 (incf dst-word-offset)))
363 (dotimes (i interior)
365 (let ((value (32bit-logical-or
366 (shift-towards-end next (- src-shift))
367 (shift-towards-start prev src-shift))))
368 (declare (type unit value))
369 (funcall dst-set-fn dst dst-word-offset value)
370 (incf dst-word-offset)))
371 (unless (zerop final-bits)
373 (if (> (+ final-bits src-shift) unit-bits)
377 (shift-towards-end next (- src-shift))
378 (shift-towards-start prev src-shift)))
379 (shift-towards-start next src-shift)))
380 (mask (start-mask final-bits))
381 (orig (funcall dst-ref-fn dst dst-word-offset)))
382 (declare (type unit mask orig value))
383 (funcall dst-set-fn dst dst-word-offset
385 (32bit-logical-and value mask)
386 (32bit-logical-andc2 orig mask))))))))
388 ;; We need to loop from right to left.
389 (incf dst-word-offset words)
390 (incf src-word-offset
391 (1- (ceiling (+ src-bit-offset length) unit-bits)))
393 (prev (funcall src-ref-fn src src-word-offset)))
394 (declare (type unit prev next))
395 (flet ((get-next-src ()
397 (setf prev (funcall src-ref-fn src
398 (decf src-word-offset)))))
399 (declare (inline get-next-src))
400 (unless (zerop final-bits)
401 (when (> final-bits (- unit-bits src-shift))
403 (let ((value (32bit-logical-or
404 (shift-towards-end next (- src-shift))
405 (shift-towards-start prev src-shift)))
406 (mask (start-mask final-bits))
407 (orig (funcall dst-ref-fn dst dst-word-offset)))
408 (declare (type unit mask orig value))
409 (funcall dst-set-fn dst dst-word-offset
411 (32bit-logical-and value mask)
412 (32bit-logical-andc2 orig mask)))))
413 (decf dst-word-offset)
414 (dotimes (i interior)
416 (let ((value (32bit-logical-or
417 (shift-towards-end next (- src-shift))
418 (shift-towards-start prev src-shift))))
419 (declare (type unit value))
420 (funcall dst-set-fn dst dst-word-offset value)
421 (decf dst-word-offset)))
422 (unless (zerop dst-bit-offset)
423 (if (> src-bit-offset dst-bit-offset)
425 (setf next prev prev 0))
426 (let ((mask (end-mask (- dst-bit-offset)))
427 (orig (funcall dst-ref-fn dst dst-word-offset))
428 (value (32bit-logical-or
429 (shift-towards-start prev src-shift)
430 (shift-towards-end next (- src-shift)))))
431 (declare (type unit mask orig value))
432 (funcall dst-set-fn dst dst-word-offset
434 (32bit-logical-and value mask)
435 (32bit-logical-andc2 orig mask)))))))))))))))
438 ;;;; the actual bashers
440 (defun bit-bash-fill (value dst dst-offset length)
441 (declare (type unit value) (type offset dst-offset length))
443 (declare (optimize (speed 3) (safety 0)))
444 (do-constant-bit-bash dst dst-offset length value
445 #'%raw-bits #'%set-raw-bits)))
447 (defun system-area-fill (value dst dst-offset length)
448 (declare (type unit value) (type offset dst-offset length))
450 (declare (optimize (speed 3) (safety 0)))
451 (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
452 (do-constant-bit-bash dst dst-offset length value
453 #'word-sap-ref #'%set-word-sap-ref))))
455 (defun bit-bash-copy (src src-offset dst dst-offset length)
456 (declare (type offset src-offset dst-offset length))
458 (declare (optimize (speed 3) (safety 0))
459 (inline do-unary-bit-bash))
460 (do-unary-bit-bash src src-offset dst dst-offset length
461 #'%raw-bits #'%set-raw-bits #'%raw-bits)))
463 (defun system-area-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 (multiple-value-bind (src src-offset) (fix-sap-and-offset src src-offset)
468 (declare (type system-area-pointer src))
469 (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
470 (declare (type system-area-pointer dst))
471 (do-unary-bit-bash src src-offset dst dst-offset length
472 #'word-sap-ref #'%set-word-sap-ref
475 (defun copy-to-system-area (src src-offset dst dst-offset length)
476 (declare (type offset src-offset dst-offset length))
478 (declare (optimize (speed 3) (safety 0)))
479 (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
480 (do-unary-bit-bash src src-offset dst dst-offset length
481 #'word-sap-ref #'%set-word-sap-ref #'%raw-bits))))
483 (defun copy-from-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 (src src-offset) (fix-sap-and-offset src src-offset)
488 (do-unary-bit-bash src src-offset dst dst-offset length
489 #'%raw-bits #'%set-raw-bits #'word-sap-ref))))
491 ;;; a common idiom for calling COPY-TO-SYSTEM-AREA
493 ;;; Copy the entire contents of the vector V to memory starting at SAP+OFFSET.
494 (defun copy-byte-vector-to-system-area (bv sap &optional (offset 0))
495 ;; FIXME: There should be a type like SB!VM:BYTE so that we can write this
496 ;; type as (SIMPLE-ARRAY SB!VM:BYTE 1). Except BYTE is an external symbol of
497 ;; package CL; so maybe SB!VM:VM-BYTE?
498 (declare (type (simple-array (unsigned-byte 8) 1) bv))
499 (declare (type sap sap))
500 (declare (type fixnum offset))
501 ;; FIXME: Actually it looks as though this, and most other calls
502 ;; to COPY-TO-SYSTEM-AREA, could be written more concisely with BYTE-BLT.
503 ;; Except that the DST-END-DST-START convention for the length is confusing.
504 ;; Perhaps I could rename BYTE-BLT to BYTE-BLIT and replace the
505 ;; DST-END argument with an N-BYTES argument?
506 (copy-to-system-area bv
507 (* sb!vm:vector-data-offset sb!vm:word-bits)
510 (* (length bv) sb!vm:byte-bits)))