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.
16 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
17 (deftype bit-offset
() '(integer 0 (#.sb
!vm
:n-word-bits
))))
21 ;;; A particular implementation must offer either VOPs to translate
22 ;;; these, or DEFTRANSFORMs to convert them into something supported
23 ;;; by the architecture.
24 (macrolet ((def (name &rest args
)
27 (def word-logical-not x
)
28 (def word-logical-and x y
)
29 (def word-logical-or x y
)
30 (def word-logical-xor x y
)
31 (def word-logical-nor x y
)
32 (def word-logical-eqv x y
)
33 (def word-logical-nand x y
)
34 (def word-logical-andc1 x y
)
35 (def word-logical-andc2 x y
)
36 (def word-logical-orc1 x y
)
37 (def word-logical-orc2 x y
))
39 ;;; Shift NUMBER by the low-order bits of COUNTOID, adding zero bits
40 ;;; at the "end" and removing bits from the "start". On big-endian
41 ;;; machines this is a left-shift and on little-endian machines this
43 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
44 (defun shift-towards-start (number countoid
)
45 (declare (type sb
!vm
:word number
) (fixnum countoid
))
46 (let ((count (ldb (byte (1- (integer-length sb
!vm
:n-word-bits
)) 0) countoid
)))
47 (declare (type bit-offset count
))
50 (ecase sb
!c
:*backend-byte-order
*
52 (ash (ldb (byte (- sb
!vm
:n-word-bits count
) 0) number
) count
))
54 (ash number
(- count
))))))))
56 ;;; Shift NUMBER by COUNT bits, adding zero bits at the "start" and
57 ;;; removing bits from the "end". On big-endian machines this is a
58 ;;; right-shift and on little-endian machines this is a left-shift.
59 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
60 (defun shift-towards-end (number count
)
61 (declare (type sb
!vm
:word number
) (fixnum count
))
62 (let ((count (ldb (byte (1- (integer-length sb
!vm
:n-word-bits
)) 0) count
)))
63 (declare (type bit-offset count
))
66 (ecase sb
!c
:*backend-byte-order
*
68 (ash number
(- count
)))
70 (ash (ldb (byte (- sb
!vm
:n-word-bits count
) 0) number
) count
)))))))
72 #!-sb-fluid
(declaim (inline start-mask end-mask
))
74 ;;; Produce a mask that contains 1's for the COUNT "start" bits and
75 ;;; 0's for the remaining "end" bits. Only the lower 5 bits of COUNT
76 ;;; are significant (KLUDGE: because of hardwired implicit dependence
77 ;;; on 32-bit word size -- WHN 2001-03-19).
78 (defun start-mask (count)
79 (declare (fixnum count
))
80 (shift-towards-start (1- (ash 1 sb
!vm
:n-word-bits
)) (- count
)))
82 ;;; Produce a mask that contains 1's for the COUNT "end" bits and 0's
83 ;;; for the remaining "start" bits. Only the lower 5 bits of COUNT are
84 ;;; significant (KLUDGE: because of hardwired implicit dependence on
85 ;;; 32-bit word size -- WHN 2001-03-19).
86 (defun end-mask (count)
87 (declare (fixnum count
))
88 (shift-towards-end (1- (ash 1 sb
!vm
:n-word-bits
)) (- count
)))
90 #!-sb-fluid
(declaim (inline word-sap-ref %set-word-sap-ref
))
91 (defun word-sap-ref (sap offset
)
92 (declare (type system-area-pointer sap
)
95 (optimize (speed 3) (safety 0) #-sb-xc-host
(inhibit-warnings 3)))
96 (sap-ref-word sap
(the index
(ash offset sb
!vm
:word-shift
))))
97 (defun %set-word-sap-ref
(sap offset value
)
98 (declare (type system-area-pointer sap
)
100 (type sb
!vm
:word value
)
102 (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
103 (setf (sap-ref-word sap
(the index
(ash offset sb
!vm
:word-shift
)))
107 ;;; the actual bashers and common uses of same
109 ;;; This is a little ugly. Fixing bug 188 would bring the ability to
110 ;;; wrap a MACROLET or something similar around this whole thing would
111 ;;; make things significantly less ugly. --njf, 2005-02-23
113 ;;; Well, it turns out that we *could* wrap a MACROLET around this,
114 ;;; but it's quite ugly in a different way: when you write
115 ;;; (MACROLET ((GENERATOR () `(DEFUN F (X) ,@(INSANITY ...))) (GENERATOR)))
116 ;;; and then view the inline expansion of F, you'll see it has actually
117 ;;; captured the entirety of the MACROLET that surrounded it.
118 ;;; With respect to building SBCL, this means, among other things, that
119 ;;; it'd hang onto all the "!" symbols that would otherwise disappear,
120 ;;; as well as kilobytes of completely useless s-expressions.
121 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
123 ;;; Align the SAP to a word boundary, and update the offset accordingly.
124 (defmacro !define-sap-fixer
(bitsize)
125 (let ((name (intern (format nil
"FIX-SAP-AND-OFFSET-UB~D" bitsize
))))
127 (declaim (inline ,name
))
128 (defun ,name
(sap offset
)
129 (declare (type system-area-pointer sap
)
131 (values system-area-pointer index
))
132 (let ((address (sap-int sap
))
133 (word-mask (1- (ash 1 word-shift
))))
134 (values (int-sap #!-alpha
(word-logical-andc2 address word-mask
)
135 ;; KLUDGE: WORD-LOGICAL-ANDC2 is defined in
136 ;; terms of n-word-bits. On all systems
137 ;; where n-word-bits is not equal to
138 ;; n-machine-word-bits we have to do this
139 ;; another way. At this time, these
140 ;; systems are alphas, though there was
141 ;; some talk about an x86-64 build option.
142 #!+alpha
(ash (ash address
(- word-shift
)) word-shift
))
144 ((1 2 4) `(* (logand address word-mask
)
145 (/ n-byte-bits
,bitsize
)))
146 ((8 16 32 64) '(logand address word-mask
)))
149 ;;; We cheat a little bit by using TRULY-THE in the copying function to
150 ;;; force the compiler to generate good code in the (= BITSIZE
151 ;;; SB!VM:N-WORD-BITS) case. We don't use TRULY-THE in the other cases
152 ;;; to give the compiler freedom to generate better code.
153 (defmacro !define-byte-bashers
(bitsize)
154 (let* ((bytes-per-word (/ n-word-bits bitsize
))
155 (byte-offset `(integer 0 (,bytes-per-word
)))
156 (byte-count `(integer 1 (,bytes-per-word
)))
157 (max-bytes (ash sb
!xc
:most-positive-fixnum
158 ;; FIXME: this reflects code contained in the
159 ;; original bit-bash.lisp, but seems very
160 ;; nonsensical. Why shouldn't we be able to
161 ;; handle M-P-FIXNUM bits? And if we can't,
162 ;; are these other shift amounts bogus, too?
171 (offset `(integer 0 ,max-bytes
))
172 (max-word-offset (ceiling max-bytes bytes-per-word
))
173 (word-offset `(integer 0 ,max-word-offset
))
174 (fix-sap-and-offset-name (intern (format nil
"FIX-SAP-AND-OFFSET-UB~D" bitsize
)))
175 (constant-bash-name (intern (format nil
"CONSTANT-UB~D-BASH" bitsize
) (find-package "SB!KERNEL")))
176 (array-fill-name (intern (format nil
"UB~D-BASH-FILL" bitsize
) (find-package "SB!KERNEL")))
177 (system-area-fill-name (intern (format nil
"SYSTEM-AREA-UB~D-FILL" bitsize
) (find-package "SB!KERNEL")))
178 (unary-bash-name (intern (format nil
"UNARY-UB~D-BASH" bitsize
) (find-package "SB!KERNEL")))
179 (array-copy-name (intern (format nil
"UB~D-BASH-COPY" bitsize
) (find-package "SB!KERNEL")))
180 (system-area-copy-name (intern (format nil
"SYSTEM-AREA-UB~D-COPY" bitsize
) (find-package "SB!KERNEL")))
181 (array-copy-to-system-area-name
182 (intern (format nil
"COPY-UB~D-TO-SYSTEM-AREA" bitsize
) (find-package "SB!KERNEL")))
183 (system-area-copy-to-array-name
184 (intern (format nil
"COPY-UB~D-FROM-SYSTEM-AREA" bitsize
)
185 (find-package "SB!KERNEL"))))
187 (declaim (inline ,constant-bash-name
,unary-bash-name
))
188 ;; Fill DST with VALUE starting at DST-OFFSET and continuing
189 ;; for LENGTH bytes (however bytes are defined).
190 (defun ,constant-bash-name
(dst dst-offset length value
191 dst-ref-fn dst-set-fn
)
192 (declare (type word value
) (type index dst-offset length
))
193 (declare (ignorable dst-ref-fn
))
194 (multiple-value-bind (dst-word-offset dst-byte-offset
)
195 (floor dst-offset
,bytes-per-word
)
196 (declare (type ,word-offset dst-word-offset
)
197 (type ,byte-offset dst-byte-offset
))
198 (multiple-value-bind (n-words final-bytes
)
199 (floor (+ dst-byte-offset length
) ,bytes-per-word
)
200 (declare (type ,word-offset n-words
)
201 (type ,byte-offset final-bytes
))
203 ,(unless (= bytes-per-word
1)
204 `(unless (zerop length
)
205 (locally (declare (type ,byte-count length
))
206 (funcall dst-set-fn dst dst-word-offset
207 (if (= length
,bytes-per-word
)
209 (let ((mask (shift-towards-end
210 (start-mask (* length
,bitsize
))
211 (* dst-byte-offset
,bitsize
))))
212 (word-logical-or (word-logical-and value mask
)
213 (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset
)
215 (let ((interior (floor (- length final-bytes
) ,bytes-per-word
)))
216 ,@(unless (= bytes-per-word
1)
217 `((unless (zerop dst-byte-offset
)
218 (let ((mask (end-mask (* (- dst-byte-offset
) ,bitsize
))))
219 (funcall dst-set-fn dst dst-word-offset
220 (word-logical-or (word-logical-and value mask
)
221 (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset
)
223 (incf dst-word-offset
))))
224 (let ((end (+ dst-word-offset interior
)))
225 (declare (type ,word-offset end
))
227 ((>= dst-word-offset end
))
228 (funcall dst-set-fn dst dst-word-offset value
)
229 (incf dst-word-offset
)))
231 (dotimes (i interior
)
232 (funcall dst-set-fn dst dst-word-offset value
)
233 (incf dst-word-offset
))
234 ,@(unless (= bytes-per-word
1)
235 `((unless (zerop final-bytes
)
236 (let ((mask (start-mask (* final-bytes
,bitsize
))))
237 (funcall dst-set-fn dst dst-word-offset
238 (word-logical-or (word-logical-and value mask
)
239 (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset
)
243 ;; common uses for constant-byte-bashing
244 (defknown ,array-fill-name
(word simple-unboxed-array
,offset
,offset
)
248 (defun ,array-fill-name
(value dst dst-offset length
)
249 (declare (type word value
) (type ,offset dst-offset length
))
250 (declare (optimize (speed 3) (safety 1)))
251 (,constant-bash-name dst dst-offset length value
252 #'%vector-raw-bits
#'%set-vector-raw-bits
)
254 (defun ,system-area-fill-name
(value dst dst-offset length
)
255 (declare (type word value
) (type ,offset dst-offset length
))
256 (declare (optimize (speed 3) (safety 1)))
257 (multiple-value-bind (dst dst-offset
) (,fix-sap-and-offset-name dst dst-offset
)
258 (,constant-bash-name dst dst-offset length value
259 #'word-sap-ref
#'%set-word-sap-ref
)))
261 ;; unary byte bashing (copying)
262 (defun ,unary-bash-name
(src src-offset dst dst-offset length
263 dst-ref-fn dst-set-fn src-ref-fn
)
264 (declare (type index src-offset dst-offset length
)
265 (type function dst-ref-fn dst-set-fn src-ref-fn
)
266 (ignorable dst-ref-fn
))
267 (multiple-value-bind (dst-word-offset dst-byte-offset
)
268 (floor dst-offset
,bytes-per-word
)
269 (declare (type ,word-offset dst-word-offset
)
270 (type ,byte-offset dst-byte-offset
))
271 (multiple-value-bind (src-word-offset src-byte-offset
)
272 (floor src-offset
,bytes-per-word
)
273 (declare (type ,word-offset src-word-offset
)
274 (type ,byte-offset src-byte-offset
))
276 ((<= (+ dst-byte-offset length
) ,bytes-per-word
)
277 ;; We are only writing one word, so it doesn't matter what
278 ;; order we do it in. But we might be reading from
279 ;; multiple words, so take care.
282 ;; We're not writing anything. This is really easy.
284 ((= length
,bytes-per-word
)
285 ;; DST-BYTE-OFFSET must be equal to zero, or we would be
286 ;; writing multiple words. If SRC-BYTE-OFFSET is also zero,
287 ;; the we just transfer the single word. Otherwise we have
288 ;; to extract bytes from two source words.
289 (funcall dst-set-fn dst dst-word-offset
291 ((zerop src-byte-offset
)
292 (funcall src-ref-fn src src-word-offset
))
293 ,@(unless (= bytes-per-word
1)
294 `((t (word-logical-or (shift-towards-start
295 (funcall src-ref-fn src src-word-offset
)
296 (* src-byte-offset
,bitsize
))
298 (funcall src-ref-fn src
(1+ src-word-offset
))
299 (* (- src-byte-offset
) ,bitsize
)))))))))
300 ,@(unless (= bytes-per-word
1)
302 ;; We are only writing some portion of the destination word.
303 ;; We still don't know whether we need one or two source words.
304 (locally (declare (type ,byte-count length
))
305 (let ((mask (shift-towards-end (start-mask (* length
,bitsize
))
306 (* dst-byte-offset
,bitsize
)))
307 (orig (funcall dst-ref-fn dst dst-word-offset
))
308 (value (if (> src-byte-offset dst-byte-offset
)
309 ;; The source starts further
310 ;; into the word than does the
311 ;; destination, so the source
312 ;; could extend into the next
313 ;; word. If it does, we have
314 ;; to merge the two words, and
315 ;; it not, we can just shift
317 (let ((src-byte-shift (- src-byte-offset
319 (if (> (+ src-byte-offset length
) ,bytes-per-word
)
322 (funcall src-ref-fn src src-word-offset
)
323 (* src-byte-shift
,bitsize
))
325 (funcall src-ref-fn src
(1+ src-word-offset
))
326 (* (- src-byte-shift
) ,bitsize
)))
327 (shift-towards-start (funcall src-ref-fn src src-word-offset
)
328 (* src-byte-shift
,bitsize
))))
329 ;; The destination starts further
330 ;; into the word than does the
331 ;; source, so we know the source
332 ;; cannot extend into a second
333 ;; word (or else the destination
334 ;; would too, and we wouldn't be
337 (funcall src-ref-fn src src-word-offset
)
338 (* (- dst-byte-offset src-byte-offset
) ,bitsize
)))))
339 (declare (type word mask orig value
))
340 (funcall dst-set-fn dst dst-word-offset
341 (word-logical-or (word-logical-and value mask
)
342 (word-logical-andc2 orig mask
))))))))))
343 ((= src-byte-offset dst-byte-offset
)
344 ;; The source and destination are aligned, so shifting
345 ;; is unnecessary. But we have to pick the direction
346 ;; of the copy in case the source and destination are
347 ;; really the same object.
348 (multiple-value-bind (words final-bytes
)
349 (floor (+ dst-byte-offset length
) ,bytes-per-word
)
350 (declare (type ,word-offset words
)
351 (type ,byte-offset final-bytes
))
352 (let ((interior (floor (- length final-bytes
) ,bytes-per-word
)))
353 (declare (type ,word-offset interior
))
355 ((<= dst-offset src-offset
)
356 ;; We need to loop from left to right.
357 ,@(unless (= bytes-per-word
1)
358 `((unless (zerop dst-byte-offset
)
359 ;; We are only writing part of the first word, so mask
360 ;; off the bytes we want to preserve.
361 (let ((mask (end-mask (* (- dst-byte-offset
) ,bitsize
)))
362 (orig (funcall dst-ref-fn dst dst-word-offset
))
363 (value (funcall src-ref-fn src src-word-offset
)))
364 (declare (type word mask orig value
))
365 (funcall dst-set-fn dst dst-word-offset
366 (word-logical-or (word-logical-and value mask
)
367 (word-logical-andc2 orig mask
))))
368 (incf src-word-offset
)
369 (incf dst-word-offset
))))
370 ;; Copy the interior words.
371 (let ((end ,(if (= bytes-per-word
1)
372 `(truly-the ,word-offset
373 (+ dst-word-offset interior
))
374 `(+ dst-word-offset interior
))))
375 (declare (type ,word-offset end
))
377 ((>= dst-word-offset end
))
378 (funcall dst-set-fn dst dst-word-offset
379 (funcall src-ref-fn src src-word-offset
))
380 ,(if (= bytes-per-word
1)
381 `(setf src-word-offset
(truly-the ,word-offset
(+ src-word-offset
1)))
382 `(incf src-word-offset
))
383 (incf dst-word-offset
)))
384 ,@(unless (= bytes-per-word
1)
385 `((unless (zerop final-bytes
)
386 ;; We are only writing part of the last word.
387 (let ((mask (start-mask (* final-bytes
,bitsize
)))
388 (orig (funcall dst-ref-fn dst dst-word-offset
))
389 (value (funcall src-ref-fn src src-word-offset
)))
390 (declare (type word mask orig value
))
391 (funcall dst-set-fn dst dst-word-offset
392 (word-logical-or (word-logical-and value mask
)
393 (word-logical-andc2 orig mask
))))))))
395 ;; We need to loop from right to left.
396 ,(if (= bytes-per-word
1)
397 `(setf dst-word-offset
(truly-the ,word-offset
398 (+ dst-word-offset words
)))
399 `(incf dst-word-offset words
))
400 ,(if (= bytes-per-word
1)
401 `(setf src-word-offset
(truly-the ,word-offset
402 (+ src-word-offset words
)))
403 `(incf src-word-offset words
))
404 ,@(unless (= bytes-per-word
1)
405 `((unless (zerop final-bytes
)
406 (let ((mask (start-mask (* final-bytes
,bitsize
)))
407 (orig (funcall dst-ref-fn dst dst-word-offset
))
408 (value (funcall src-ref-fn src src-word-offset
)))
409 (declare (type word mask orig value
))
410 (funcall dst-set-fn dst dst-word-offset
411 (word-logical-or (word-logical-and value mask
)
412 (word-logical-andc2 orig mask
)))))))
413 (let ((end (- dst-word-offset interior
)))
415 ((<= dst-word-offset end
))
416 (decf src-word-offset
)
417 (decf dst-word-offset
)
418 (funcall dst-set-fn dst dst-word-offset
419 (funcall src-ref-fn src src-word-offset
))))
420 ,@(unless (= bytes-per-word
1)
421 `((unless (zerop dst-byte-offset
)
422 ;; We are only writing part of the last word.
423 (decf src-word-offset
)
424 (decf dst-word-offset
)
425 (let ((mask (end-mask (* (- dst-byte-offset
) ,bitsize
)))
426 (orig (funcall dst-ref-fn dst dst-word-offset
))
427 (value (funcall src-ref-fn src src-word-offset
)))
428 (declare (type word mask orig value
))
429 (funcall dst-set-fn dst dst-word-offset
430 (word-logical-or (word-logical-and value mask
)
431 (word-logical-andc2 orig mask
))))))))))))
433 ;; Source and destination are not aligned.
434 (multiple-value-bind (words final-bytes
)
435 (floor (+ dst-byte-offset length
) ,bytes-per-word
)
436 (declare (type ,word-offset words
)
437 (type ,byte-offset final-bytes
))
438 (let ((src-shift (mod (- src-byte-offset dst-byte-offset
)
440 (interior (floor (- length final-bytes
) ,bytes-per-word
)))
441 (declare (type ,word-offset interior
)
442 (type ,byte-offset src-shift
))
444 ((<= dst-offset src-offset
)
445 ;; We need to loop from left to right.
447 (next (funcall src-ref-fn src src-word-offset
)))
448 (declare (type word prev next
))
449 (flet ((get-next-src ()
451 (setf next
(funcall src-ref-fn src
452 (incf src-word-offset
)))))
453 (declare (inline get-next-src
))
454 ,@(unless (= bytes-per-word
1)
455 `((unless (zerop dst-byte-offset
)
456 (when (> src-byte-offset dst-byte-offset
)
458 (let ((mask (end-mask (* (- dst-byte-offset
) ,bitsize
)))
459 (orig (funcall dst-ref-fn dst dst-word-offset
))
460 (value (word-logical-or (shift-towards-start prev
(* src-shift
,bitsize
))
461 (shift-towards-end next
(* (- src-shift
) ,bitsize
)))))
462 (declare (type word mask orig value
))
463 (funcall dst-set-fn dst dst-word-offset
464 (word-logical-or (word-logical-and value mask
)
465 (word-logical-andc2 orig mask
))))
466 (incf dst-word-offset
))))
467 (let ((end (+ dst-word-offset interior
)))
468 (declare (type ,word-offset end
))
470 ((>= dst-word-offset end
))
472 (let ((value (word-logical-or
473 (shift-towards-end next
(* (- src-shift
) ,bitsize
))
474 (shift-towards-start prev
(* src-shift
,bitsize
)))))
475 (declare (type word value
))
476 (funcall dst-set-fn dst dst-word-offset value
)
477 (incf dst-word-offset
))))
478 ,@(unless (= bytes-per-word
1)
479 `((unless (zerop final-bytes
)
481 (if (> (+ final-bytes src-shift
) ,bytes-per-word
)
485 (shift-towards-end next
(* (- src-shift
) ,bitsize
))
486 (shift-towards-start prev
(* src-shift
,bitsize
))))
487 (shift-towards-start next
(* src-shift
,bitsize
))))
488 (mask (start-mask (* final-bytes
,bitsize
)))
489 (orig (funcall dst-ref-fn dst dst-word-offset
)))
490 (declare (type word mask orig value
))
491 (funcall dst-set-fn dst dst-word-offset
492 (word-logical-or (word-logical-and value mask
)
493 (word-logical-andc2 orig mask
))))))))))
495 ;; We need to loop from right to left.
496 (incf dst-word-offset words
)
497 (incf src-word-offset
(1- (ceiling (+ src-byte-offset length
) ,bytes-per-word
)))
499 (prev (funcall src-ref-fn src src-word-offset
)))
500 (declare (type word prev next
))
501 (flet ((get-next-src ()
503 (setf prev
(funcall src-ref-fn src
(decf src-word-offset
)))))
504 (declare (inline get-next-src
))
505 ,@(unless (= bytes-per-word
1)
506 `((unless (zerop final-bytes
)
507 (when (> final-bytes
(- ,bytes-per-word src-shift
))
509 (let ((value (word-logical-or
510 (shift-towards-end next
(* (- src-shift
) ,bitsize
))
511 (shift-towards-start prev
(* src-shift
,bitsize
))))
512 (mask (start-mask (* final-bytes
,bitsize
)))
513 (orig (funcall dst-ref-fn dst dst-word-offset
)))
514 (declare (type word mask orig value
))
515 (funcall dst-set-fn dst dst-word-offset
516 (word-logical-or (word-logical-and value mask
)
517 (word-logical-andc2 orig mask
)))))))
518 (decf dst-word-offset
)
519 (let ((end (- dst-word-offset interior
)))
521 ((<= dst-word-offset end
))
523 (let ((value (word-logical-or
524 (shift-towards-end next
(* (- src-shift
) ,bitsize
))
525 (shift-towards-start prev
(* src-shift
,bitsize
)))))
526 (declare (type word value
))
527 (funcall dst-set-fn dst dst-word-offset value
)
528 (decf dst-word-offset
))))
529 ,@(unless (= bytes-per-word
1)
530 `((unless (zerop dst-byte-offset
)
531 (if (> src-byte-offset dst-byte-offset
)
533 (setf next prev prev
0))
534 (let ((mask (end-mask (* (- dst-byte-offset
) ,bitsize
)))
535 (orig (funcall dst-ref-fn dst dst-word-offset
))
536 (value (word-logical-or
537 (shift-towards-start prev
(* src-shift
,bitsize
))
538 (shift-towards-end next
(* (- src-shift
) ,bitsize
)))))
539 (declare (type word mask orig value
))
540 (funcall dst-set-fn dst dst-word-offset
541 (word-logical-or (word-logical-and value mask
)
542 (word-logical-andc2 orig mask
)))))))))))))))))
545 ;; common uses for unary-byte-bashing
546 (defun ,array-copy-name
(src src-offset dst dst-offset length
)
547 (declare (type ,offset src-offset dst-offset length
))
548 (locally (declare (optimize (speed 3) (safety 1)))
549 (,unary-bash-name src src-offset dst dst-offset length
551 #'%set-vector-raw-bits
552 #'%vector-raw-bits
)))
554 (defun ,system-area-copy-name
(src src-offset dst dst-offset length
)
555 (declare (type ,offset src-offset dst-offset length
))
556 (locally (declare (optimize (speed 3) (safety 1)))
557 (multiple-value-bind (src src-offset
) (,fix-sap-and-offset-name src src-offset
)
558 (declare (type system-area-pointer src
))
559 (multiple-value-bind (dst dst-offset
) (,fix-sap-and-offset-name dst dst-offset
)
560 (declare (type system-area-pointer dst
))
561 (,unary-bash-name src src-offset dst dst-offset length
562 #'word-sap-ref
#'%set-word-sap-ref
565 (defun ,array-copy-to-system-area-name
(src src-offset dst dst-offset length
)
566 (declare (type ,offset src-offset dst-offset length
))
567 (locally (declare (optimize (speed 3) (safety 1)))
568 (multiple-value-bind (dst dst-offset
) (,fix-sap-and-offset-name dst dst-offset
)
569 (,unary-bash-name src src-offset dst dst-offset length
570 #'word-sap-ref
#'%set-word-sap-ref
571 #'%vector-raw-bits
))))
573 (defun ,system-area-copy-to-array-name
(src src-offset dst dst-offset length
)
574 (declare (type ,offset src-offset dst-offset length
))
575 (locally (declare (optimize (speed 3) (safety 1)))
576 (multiple-value-bind (src src-offset
) (,fix-sap-and-offset-name src src-offset
)
577 (,unary-bash-name src src-offset dst dst-offset length
579 #'%set-vector-raw-bits
580 #'word-sap-ref
)))))))
583 (eval-when (:compile-toplevel
)
584 (sb!xc
:proclaim
'(muffle-conditions compiler-note
)))
585 ;;; We would normally do this with a MACROLET, but then we run into
586 ;;; problems with the lexical environment being too hairy for the
587 ;;; cross-compiler and it cannot inline the basic basher functions.
588 #.
(loop for i
= 1 then
(* i
2)
589 collect
`(!define-sap-fixer
,i
) into fixers
590 collect
`(!define-byte-bashers
,i
) into bashers
591 until
(= i sb
!vm
:n-word-bits
)
592 ;; FIXERS must come first so their inline expansions are available
594 finally
(return `(progn ,@fixers
,@bashers
)))
596 ;;; a common idiom for calling COPY-TO-SYSTEM-AREA
598 ;;; Copy the entire contents of the vector V to memory starting at SAP+OFFSET.
599 (defun copy-byte-vector-to-system-area (bv sap
&optional
(offset 0))
600 ;; FIXME: There should be a type like SB!VM:BYTE so that we can write this
601 ;; type as (SIMPLE-ARRAY SB!VM:BYTE 1). Except BYTE is an external symbol of
602 ;; package CL, and shadowing it would be too ugly; so maybe SB!VM:VMBYTE?
603 ;; (And then N-BYTE-BITS would be N-VMBYTE-BITS and so forth?)
604 (declare (type (simple-array (unsigned-byte 8) 1) bv
))
605 (declare (type system-area-pointer sap
))
606 (declare (type fixnum offset
))
607 (copy-ub8-to-system-area bv
0 sap offset
(length bv
)))
610 ;;;; Bashing-Style search for bits
612 ;;;; Similar search would work well for base-strings as well.
613 ;;;; (Technically for all unboxed sequences of sub-word size elements,
614 ;;;; but somehow I doubt eg. octet vectors get POSITION or FIND used
615 ;;;; as much on them.)
616 (defconstant +bit-position-base-mask
+ (1- n-word-bits
))
617 (defconstant +bit-position-base-shift
+ (integer-length +bit-position-base-mask
+))
618 (macrolet ((def (name frob
)
619 `(defun ,name
(vector from-end start end
)
620 (declare (simple-bit-vector vector
)
622 (optimize (speed 3) (safety 0)))
623 (unless (= start end
)
624 (let* ((last-word (ash end
(- +bit-position-base-shift
+)))
625 (last-bits (logand end
+bit-position-base-mask
+))
626 (first-word (ash start
(- +bit-position-base-shift
+)))
627 (first-bits (logand start
+bit-position-base-mask
+))
628 ;; These mask out everything but the interesting parts.
629 (end-mask #!+little-endian
(lognot (ash -
1 last-bits
))
630 #!+big-endian
(ash -
1 (- sb
!vm
:n-word-bits last-bits
)))
631 (start-mask #!+little-endian
(ash -
1 first-bits
)
632 #!+big-endian
(lognot (ash -
1 (- sb
!vm
:n-word-bits first-bits
)))))
633 (declare (index last-word first-word
))
634 (flet ((#!+little-endian start-bit
635 #!+big-endian end-bit
(x)
638 (truly-the (mod #.n-word-bits
)
639 (%primitive unsigned-word-find-first-bit x
))
641 (- #!+big-endian sb
!vm
:n-word-bits
642 (integer-length (logand x
(- x
)))
644 (#!+little-endian end-bit
645 #!+big-endian start-bit
(x)
647 (- #!+big-endian sb
!vm
:n-word-bits
650 (found (i word-offset
)
651 (declare (index i word-offset
))
655 (ash word-offset
+bit-position-base-shift
+)))))
657 (,@frob
(%vector-raw-bits vector offset
))))
658 ;; Inline FOUND makes the code smaller, as well as faster,
659 ;; because it becomes clear that there is no establishing
660 ;; of an exit point and hence no call to UNWIND.
661 (declare (inline start-bit end-bit found get-word
))
664 (let* ((word-offset last-word
)
665 (word (logand end-mask
(get-word word-offset
))))
669 (when (= word-offset first-word
)
670 (setf word
(logand word start-mask
)))
672 (found (end-bit word
) word-offset
)))
675 (when (< word-offset first-word
)
676 (return-from ,name nil
))
677 (setf word
(get-word word-offset
))
679 (when (= word-offset first-word
)
680 (setf word
(logand word start-mask
)))
682 (found (end-bit word
) word-offset
)))
685 (let* ((word-offset first-word
)
686 (word (logand start-mask
(get-word word-offset
))))
690 (when (= word-offset last-word
)
691 (setf word
(logand word end-mask
)))
693 (found (start-bit word
) word-offset
)))
696 (when (> word-offset last-word
)
697 (return-from ,name nil
))
698 (setf word
(get-word word-offset
))
700 (when (= word-offset last-word
)
701 (setf word
(logand word end-mask
)))
703 (found (start-bit word
) word-offset
)))
704 (incf word-offset
))))))))))
705 (def %bit-position
/0 (logandc2 #.
(1- (expt 2 n-word-bits
))))
706 (def %bit-position
/1 (identity)))
707 (defun %bit-position
(bit vector from-end start end
)
709 (0 (%bit-position
/0 vector from-end start end
))
710 (1 (%bit-position
/1 vector from-end start end
))