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 n-word-bits)
19 ;;; the maximum number of bits that can be dealt with in a single call
20 (defconstant max-bits (ash sb!xc: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 (name &rest args)
45 (def word-logical-not x)
46 (def word-logical-and x y)
47 (def word-logical-or x y)
48 (def word-logical-xor x y)
49 (def word-logical-nor x y)
50 (def word-logical-eqv x y)
51 (def word-logical-nand x y)
52 (def word-logical-andc1 x y)
53 (def word-logical-andc2 x y)
54 (def word-logical-orc1 x y)
55 (def word-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 (word-logical-andc2 address
113 sb!vm::fixnum-tag-mask)
114 #!+alpha (ash (ash address -2) 2))
115 (+ (* (logand address sb!vm::fixnum-tag-mask) n-byte-bits)
118 #!-sb-fluid (declaim (inline word-sap-ref %set-word-sap-ref))
119 (defun word-sap-ref (sap offset)
120 (declare (type system-area-pointer sap)
123 (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3)))
124 (sap-ref-word sap (the index (ash offset sb!vm::n-fixnum-tag-bits))))
125 (defun %set-word-sap-ref (sap offset value)
126 (declare (type system-area-pointer sap)
128 (type sb!vm:word value)
130 (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
131 (setf (sap-ref-word sap (the index (ash offset sb!vm::n-fixnum-tag-bits)))
134 ;;;; CONSTANT-BIT-BASH
136 ;;; Fill DST with VALUE starting at DST-OFFSET and continuing for
138 #!-sb-fluid (declaim (inline constant-bit-bash))
139 (defun constant-bit-bash (dst dst-offset length value dst-ref-fn dst-set-fn)
140 (declare (type offset dst-offset) (type unit value)
141 (type function dst-ref-fn dst-set-fn))
142 (multiple-value-bind (dst-word-offset dst-bit-offset)
143 (floor dst-offset unit-bits)
144 (declare (type word-offset dst-word-offset)
145 (type bit-offset dst-bit-offset))
146 (multiple-value-bind (words final-bits)
147 (floor (+ dst-bit-offset length) unit-bits)
148 (declare (type word-offset words) (type bit-offset final-bits))
150 (unless (zerop length)
151 (funcall dst-set-fn dst dst-word-offset
152 (if (= length unit-bits)
154 (let ((mask (shift-towards-end (start-mask length)
156 (declare (type unit mask))
158 (word-logical-and value mask)
160 (funcall dst-ref-fn dst dst-word-offset)
162 (let ((interior (floor (- length final-bits) unit-bits)))
163 (unless (zerop dst-bit-offset)
164 (let ((mask (end-mask (- dst-bit-offset))))
165 (declare (type unit mask))
166 (funcall dst-set-fn dst dst-word-offset
168 (word-logical-and value mask)
170 (funcall dst-ref-fn dst dst-word-offset)
172 (incf dst-word-offset))
173 (dotimes (i interior)
174 (funcall dst-set-fn dst dst-word-offset value)
175 (incf dst-word-offset))
176 (unless (zerop final-bits)
177 (let ((mask (start-mask final-bits)))
178 (declare (type unit mask))
179 (funcall dst-set-fn dst dst-word-offset
181 (word-logical-and value mask)
183 (funcall dst-ref-fn dst dst-word-offset)
189 #!-sb-fluid (declaim (inline unary-bit-bash))
190 (defun unary-bit-bash (src src-offset dst dst-offset length
191 dst-ref-fn dst-set-fn src-ref-fn)
192 ;; FIXME: Declaring these bit indices to be of type OFFSET, then
193 ;; using the inline expansion in SPEED 3 SAFETY 0 functions, is not
194 ;; a good thing. At the very least, we should make sure that the
195 ;; type (overflow) checks get done. Better would be to avoid
196 ;; using bit indices, and to use 32-bit unsigneds instead, and/or
197 ;; to call out to things like memmove(3) for big moves.
198 (declare (type offset src-offset dst-offset length)
199 (type function dst-ref-fn dst-set-fn src-ref-fn))
200 (multiple-value-bind (dst-word-offset dst-bit-offset)
201 (floor dst-offset unit-bits)
202 (declare (type word-offset dst-word-offset)
203 (type bit-offset dst-bit-offset))
204 (multiple-value-bind (src-word-offset src-bit-offset)
205 (floor src-offset unit-bits)
206 (declare (type word-offset src-word-offset)
207 (type bit-offset src-bit-offset))
209 ((<= (+ dst-bit-offset length) unit-bits)
210 ;; We are only writing one word, so it doesn't matter what
211 ;; order we do it in. But we might be reading from multiple
212 ;; words, so take care.
215 ;; Actually, we aren't even writing one word. This is really easy.
217 ((= length unit-bits)
218 ;; DST-BIT-OFFSET must be equal to zero, or we would be
219 ;; writing multiple words. If SRC-BIT-OFFSET is also zero,
220 ;; then we just transfer the single word. Otherwise we have
221 ;; to extract bits from two src words.
222 (funcall dst-set-fn dst dst-word-offset
223 (if (zerop src-bit-offset)
224 (funcall src-ref-fn src src-word-offset)
227 (funcall src-ref-fn src src-word-offset)
230 (funcall src-ref-fn src (1+ src-word-offset))
231 (- src-bit-offset))))))
233 ;; We are only writing some portion of the dst word, so we
234 ;; need to preserve the extra bits. Also, we still don't
235 ;; know whether we need one or two source words.
236 (let ((mask (shift-towards-end (start-mask length) dst-bit-offset))
237 (orig (funcall dst-ref-fn dst dst-word-offset))
239 (if (> src-bit-offset dst-bit-offset)
240 ;; The source starts further into the word than
241 ;; does the dst, so the source could extend into
242 ;; the next word. If it does, we have to merge
243 ;; the two words, and if not, we can just shift
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
258 ;; the source, so we know the source can not
259 ;; extend into a second word (or else the dst
260 ;; would too, and we 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 (word-logical-and value mask)
269 (word-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 in
273 ;; 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
284 ;; off the 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 (word-logical-or (word-logical-and value mask)
291 (word-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 (word-logical-and value mask)
309 (word-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 (word-logical-and value mask)
322 (word-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 (word-logical-and value mask)
338 (word-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 (word-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 (word-logical-and value mask)
371 (word-logical-andc2 orig mask)))
372 (incf dst-word-offset)))
373 (dotimes (i interior)
375 (let ((value (word-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 (word-logical-and value mask)
396 (word-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 (word-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 (word-logical-and value mask)
422 (word-logical-andc2 orig mask)))))
423 (decf dst-word-offset)
424 (dotimes (i interior)
426 (let ((value (word-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 (word-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 (word-logical-and value mask)
445 (word-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 (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 (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 unary-bit-bash))
470 (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 (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 (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 (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, and shadowing it would be too ugly; so maybe SB!VM:VMBYTE?
508 ;; (And then N-BYTE-BITS would be N-VMBYTE-BITS and so forth?)
509 (declare (type (simple-array (unsigned-byte 8) 1) bv))
510 (declare (type system-area-pointer sap))
511 (declare (type fixnum offset))
512 ;; FIXME: Actually it looks as though this, and most other calls to
513 ;; COPY-TO-SYSTEM-AREA, could be written more concisely with
514 ;; %BYTE-BLT. Except that the DST-END-DST-START convention for the
515 ;; length is confusing. Perhaps I could rename %BYTE-BLT to
516 ;; %BYTE-BLIT (and correspondingly rename the corresponding VOP) and
517 ;; replace the DST-END argument with an N-BYTES argument?
518 (copy-to-system-area bv
519 (* vector-data-offset n-word-bits)
522 (* (length bv) n-byte-bits)))