Newer
Older
;;; -*- Log: code.log; Package: VM -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: src/code/bit-bash.lisp $")
;;; **********************************************************************
;;;
;;; Functions to implement bit bashing.
;;;
;;; Written by William Lott.
;;;
(intl:textdomain "cmucl")
;;;; Constants and Types.
(eval-when (compile load eval)
(defconstant unit-bits vm:word-bits
"The number of bits to process at a time.")
(defconstant unit-bytes vm:word-bytes
"The number of bytes to process at a time.")
"The maximum number of bits that can be dealt with during a single call.")
`(unsigned-byte ,unit-bits))
(deftype offset ()
`(integer 0 ,max-bits))
(deftype bit-offset ()
`(integer 0 (,unit-bits)))
(deftype byte-offset ()
`(integer 0 (,unit-bytes)))
(deftype bit-count ()
`(integer 1 (,unit-bits)))
(deftype word-offset ()
`(integer 0 (,(ceiling max-bits unit-bits))))
); eval-when
;;;; Support routines.
;;; A particular implementation must offer either VOPs to translate these, or
;;; deftransforms to convert them into something supported by the architecture.
;;;
(macrolet ((frob (name &rest args)
`(defun ,name ,args
(,name ,@args))))
(frob 32bit-logical-not x)
(frob 32bit-logical-and x y)
(frob 32bit-logical-or x y)
(frob 32bit-logical-xor x y)
(frob 32bit-logical-nor x y)
(frob 32bit-logical-eqv x y)
(frob 32bit-logical-nand x y)
(frob 32bit-logical-andc1 x y)
(frob 32bit-logical-andc2 x y)
(frob 32bit-logical-orc1 x y)
(frob 32bit-logical-orc2 x y))
(eval-when (compile eval)
(defmacro byte-order-dispatch (big-endian little-endian)
(ecase (c:backend-byte-order c:*target-backend*)
(:big-endian big-endian)
(:little-endian little-endian))))
(defun shift-towards-start (number count)
"Shift NUMBER by COUNT bits, adding zero bits at the ``end'' and removing
bits from the ``start.'' On big-endian machines this is a left-shift and
on little-endian machines this is a right-shift. Note: only the low 5/6 bits
of count are significant."
(declare (type unit number) (fixnum count))
(let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count)))
(declare (type bit-offset count))
(if (zerop count)
number
(byte-order-dispatch
(ash (ldb (byte (- unit-bits count) 0) number) count)
(ash number (- count))))))
(defun shift-towards-end (number count)
"Shift NUMBER by COUNT bits, adding zero bits at the ``start'' and removing
bits from the ``end.'' On big-endian machines this is a right-shift and
on little-endian machines this is a left-shift."
(declare (type unit number) (fixnum count))
(let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count)))
(declare (type bit-offset count))
(if (zerop count)
number
(byte-order-dispatch
(ash number (- count))
(ash (ldb (byte (- unit-bits count) 0) number) count)))))
(declaim (inline start-mask end-mask fix-sap-and-offset))
(defun start-mask (count)
"Produce a mask that contains 1's for the COUNT ``start'' bits and 0's for
the remaining ``end'' bits. Only the lower 5 bits of COUNT are significant."
(declare (fixnum count))
(shift-towards-start (1- (ash 1 unit-bits)) (- count)))
(defun end-mask (count)
"Produce a mask that contains 1's for the COUNT ``end'' bits and 0's for
the remaining ``start'' bits. Only the lower 5 bits of COUNT are
significant."
(declare (fixnum count))
(shift-towards-end (1- (ash 1 unit-bits)) (- count)))
(defun fix-sap-and-offset (sap offset)
"Align the SAP to a word boundry, and update the offset accordingly."
(declare (type system-area-pointer sap)
(type index offset)
(values system-area-pointer index))
(let ((address (sap-int sap)))
(values (int-sap #-(or alpha amd64) (32bit-logical-andc2 address 3)
#+alpha (ash (ash address -2) 2)
#+amd64 (ash (ash address -3) 3))
(+ (* (logand address #+amd64 7 #-amd64 3) byte-bits) offset))))
(declaim (inline word-sap-ref %set-word-sap-ref))
;;;
(defun word-sap-ref (sap offset)
(declare (type system-area-pointer sap)
(type index offset)
(optimize (speed 3) (safety 0) (inhibit-warnings 3)))
#+amd64 (sap-ref-64 sap (the index (ash offset 3)))
#-amd64 (sap-ref-32 sap (the index (ash offset 2))))
(declare (type system-area-pointer sap)
(type index offset)
(type (unsigned-byte #+amd64 64 #-amd64 32) value)
(values (unsigned-byte #+amd64 64 #-amd64 32))
(optimize (speed 3) (safety 0) (inhibit-warnings 3)))
(setf #+amd64 (sap-ref-64 sap (the index (ash offset 3)))
#-amd64 (sap-ref-32 sap (the index (ash offset 2))) value))
;;;
(defsetf word-sap-ref %set-word-sap-ref)
;;;; DO-CONSTANT-BIT-BASH
(defun do-constant-bit-bash (dst dst-offset length value dst-ref-fn dst-set-fn)
"Fill DST with VALUE starting at DST-OFFSET and continuing for LENGTH bits."
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
(declare (type offset dst-offset) (type unit value)
(type function dst-ref-fn dst-set-fn))
(multiple-value-bind (dst-word-offset dst-bit-offset)
(floor dst-offset unit-bits)
(declare (type word-offset dst-word-offset)
(type bit-offset dst-bit-offset))
(multiple-value-bind (words final-bits)
(floor (+ dst-bit-offset length) unit-bits)
(declare (type word-offset words) (type bit-offset final-bits))
(if (zerop words)
(unless (zerop length)
(funcall dst-set-fn dst dst-word-offset
(if (= length unit-bits)
value
(let ((mask (shift-towards-end (start-mask length)
dst-bit-offset)))
(declare (type unit mask))
(32bit-logical-or
(32bit-logical-and value mask)
(32bit-logical-andc2
(funcall dst-ref-fn dst dst-word-offset)
mask))))))
(let ((interior (floor (- length final-bits) unit-bits)))
(unless (zerop dst-bit-offset)
(let ((mask (end-mask (- dst-bit-offset))))
(declare (type unit mask))
(funcall dst-set-fn dst dst-word-offset
(32bit-logical-or
(32bit-logical-and value mask)
(32bit-logical-andc2
(funcall dst-ref-fn dst dst-word-offset)
mask))))
(incf dst-word-offset))
(dotimes (i interior)
(funcall dst-set-fn dst dst-word-offset value)
(incf dst-word-offset))
(unless (zerop final-bits)
(let ((mask (start-mask final-bits)))
(declare (type unit mask))
(funcall dst-set-fn dst dst-word-offset
(32bit-logical-or
(32bit-logical-and value mask)
(32bit-logical-andc2
(funcall dst-ref-fn dst dst-word-offset)
mask)))))))))
(undefined-value))
;;;; DO-UNARY-BIT-BASH
(defun do-unary-bit-bash (src src-offset dst dst-offset length
dst-ref-fn dst-set-fn src-ref-fn)
(declare (type offset src-offset dst-offset length)
(type function dst-ref-fn dst-set-fn src-ref-fn))
(multiple-value-bind (dst-word-offset dst-bit-offset)
(floor dst-offset unit-bits)
(declare (type word-offset dst-word-offset)
(type bit-offset dst-bit-offset))
(multiple-value-bind (src-word-offset src-bit-offset)
(floor src-offset unit-bits)
(declare (type word-offset src-word-offset)
(type bit-offset src-bit-offset))
(cond
((<= (+ dst-bit-offset length) unit-bits)
;; We are only writing one word, so it doesn't matter what order
;; we do it in. But we might be reading from multiple words, so take
;; care.
(cond
((zerop length)
;; Actually, we aren't even writing one word. This is real easy.
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
)
((= length unit-bits)
;; dst-bit-offset must be equal to zero, or we would be writing
;; multiple words. If src-bit-offset is also zero, then we
;; just transfer the single word. Otherwise we have to extract bits
;; from two src words.
(funcall dst-set-fn dst dst-word-offset
(if (zerop src-bit-offset)
(funcall src-ref-fn src src-word-offset)
(32bit-logical-or
(shift-towards-start
(funcall src-ref-fn src src-word-offset)
src-bit-offset)
(shift-towards-end
(funcall src-ref-fn src (1+ src-word-offset))
(- src-bit-offset))))))
(t
;; We are only writing some portion of the dst word, so we need to
;; preserve the extra bits. Also, we still don't know if we need
;; one or two source words.
(let ((mask (shift-towards-end (start-mask length) dst-bit-offset))
(orig (funcall dst-ref-fn dst dst-word-offset))
(value
(if (> src-bit-offset dst-bit-offset)
;; The source starts further into the word than does
;; the dst, so the source could extend into the next
;; word. If it does, we have to merge the two words,
;; and if not, we can just shift the first word.
(let ((src-bit-shift (- src-bit-offset dst-bit-offset)))
(if (> (+ src-bit-offset length) unit-bits)
(32bit-logical-or
(shift-towards-start
(funcall src-ref-fn src src-word-offset)
src-bit-shift)
(shift-towards-end
(funcall src-ref-fn src (1+ src-word-offset))
(- src-bit-shift)))
(shift-towards-start
(funcall src-ref-fn src src-word-offset)
src-bit-shift)))
;; The dst starts further into the word than does the
;; source, so we know the source can't extend into
;; a second word (or else the dst would too, and we
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
(shift-towards-end
(funcall src-ref-fn src src-word-offset)
(- dst-bit-offset src-bit-offset)))))
(declare (type unit mask orig value))
;; Replace the dst word.
(funcall dst-set-fn dst dst-word-offset
(32bit-logical-or
(32bit-logical-and value mask)
(32bit-logical-andc2 orig mask)))))))
((= src-bit-offset dst-bit-offset)
;; The source and dst are aligned, so we don't need to shift
;; anything. But we have to pick the direction of the loop
;; in case the source and dst are really the same thing.
(multiple-value-bind (words final-bits)
(floor (+ dst-bit-offset length) unit-bits)
(declare (type word-offset words) (type bit-offset final-bits))
(let ((interior (floor (- length final-bits) unit-bits)))
(declare (type word-offset interior))
(cond
((<= dst-offset src-offset)
;; We need to loop from left to right
(unless (zerop dst-bit-offset)
;; We are only writing part of the first word, so mask off the
;; bits we want to preserve.
(let ((mask (end-mask (- dst-bit-offset)))
(orig (funcall dst-ref-fn dst dst-word-offset))
(value (funcall src-ref-fn src src-word-offset)))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
(32bit-logical-or (32bit-logical-and value mask)
(32bit-logical-andc2 orig mask))))
(incf src-word-offset)
(incf dst-word-offset))
;; Just copy the interior words.
(dotimes (i interior)
(funcall dst-set-fn dst dst-word-offset
(funcall src-ref-fn src src-word-offset))
(incf src-word-offset)
(incf dst-word-offset))
(unless (zerop final-bits)
;; We are only writing part of the last word.
(let ((mask (start-mask final-bits))
(orig (funcall dst-ref-fn dst dst-word-offset))
(value (funcall src-ref-fn src src-word-offset)))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
(32bit-logical-or
(32bit-logical-and value mask)
(32bit-logical-andc2 orig mask))))))
(t
;; We need to loop from right to left.
(incf dst-word-offset words)
(incf src-word-offset words)
(unless (zerop final-bits)
(let ((mask (start-mask final-bits))
(orig (funcall dst-ref-fn dst dst-word-offset))
(value (funcall src-ref-fn src src-word-offset)))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
(32bit-logical-or
(32bit-logical-and value mask)
(32bit-logical-andc2 orig mask)))))
(dotimes (i interior)
(decf src-word-offset)
(decf dst-word-offset)
(funcall dst-set-fn dst dst-word-offset
(funcall src-ref-fn src src-word-offset)))
(unless (zerop dst-bit-offset)
(decf src-word-offset)
(decf dst-word-offset)
(let ((mask (end-mask (- dst-bit-offset)))
(orig (funcall dst-ref-fn dst dst-word-offset))
(value (funcall src-ref-fn src src-word-offset)))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
(32bit-logical-or
(32bit-logical-and value mask)
(32bit-logical-andc2 orig mask))))))))))
(t
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
(multiple-value-bind (words final-bits)
(floor (+ dst-bit-offset length) unit-bits)
(declare (type word-offset words) (type bit-offset final-bits))
(let ((src-shift (mod (- src-bit-offset dst-bit-offset) unit-bits))
(interior (floor (- length final-bits) unit-bits)))
(declare (type bit-offset src-shift)
(type word-offset interior))
(cond
((<= dst-offset src-offset)
;; We need to loop from left to right
(let ((prev 0)
(next (funcall src-ref-fn src src-word-offset)))
(declare (type unit prev next))
(flet ((get-next-src ()
(setf prev next)
(setf next (funcall src-ref-fn src
(incf src-word-offset)))))
(declare (inline get-next-src))
(unless (zerop dst-bit-offset)
(when (> src-bit-offset dst-bit-offset)
(get-next-src))
(let ((mask (end-mask (- dst-bit-offset)))
(orig (funcall dst-ref-fn dst dst-word-offset))
(value (32bit-logical-or
(shift-towards-start prev src-shift)
(shift-towards-end next (- src-shift)))))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
(32bit-logical-or
(32bit-logical-and value mask)
(32bit-logical-andc2 orig mask)))
(incf dst-word-offset)))
(dotimes (i interior)
(get-next-src)
(let ((value (32bit-logical-or
(shift-towards-end next (- src-shift))
(shift-towards-start prev src-shift))))
(declare (type unit value))
(funcall dst-set-fn dst dst-word-offset value)
(incf dst-word-offset)))
(unless (zerop final-bits)
(let ((value
(if (> (+ final-bits src-shift) unit-bits)
(progn
(get-next-src)
(32bit-logical-or
(shift-towards-end next (- src-shift))
(shift-towards-start prev src-shift)))
(shift-towards-start next src-shift)))
(mask (start-mask final-bits))
(orig (funcall dst-ref-fn dst dst-word-offset)))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
(32bit-logical-or
(32bit-logical-and value mask)
(32bit-logical-andc2 orig mask))))))))
(t
;; We need to loop from right to left.
(incf dst-word-offset words)
(incf src-word-offset
(1- (ceiling (+ src-bit-offset length) unit-bits)))
(let ((next 0)
(prev (funcall src-ref-fn src src-word-offset)))
(declare (type unit prev next))
(flet ((get-next-src ()
(setf next prev)
(setf prev (funcall src-ref-fn src
(decf src-word-offset)))))
(declare (inline get-next-src))
(unless (zerop final-bits)
(when (> final-bits (- unit-bits src-shift))
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
(get-next-src))
(let ((value (32bit-logical-or
(shift-towards-end next (- src-shift))
(shift-towards-start prev src-shift)))
(mask (start-mask final-bits))
(orig (funcall dst-ref-fn dst dst-word-offset)))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
(32bit-logical-or
(32bit-logical-and value mask)
(32bit-logical-andc2 orig mask)))))
(decf dst-word-offset)
(dotimes (i interior)
(get-next-src)
(let ((value (32bit-logical-or
(shift-towards-end next (- src-shift))
(shift-towards-start prev src-shift))))
(declare (type unit value))
(funcall dst-set-fn dst dst-word-offset value)
(decf dst-word-offset)))
(unless (zerop dst-bit-offset)
(if (> src-bit-offset dst-bit-offset)
(get-next-src)
(setf next prev prev 0))
(let ((mask (end-mask (- dst-bit-offset)))
(orig (funcall dst-ref-fn dst dst-word-offset))
(value (32bit-logical-or
(shift-towards-start prev src-shift)
(shift-towards-end next (- src-shift)))))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
(32bit-logical-or
(32bit-logical-and value mask)
(32bit-logical-andc2 orig mask)))))))))))))))
(undefined-value))
;;;; DO-UNARY-BYTE-BASH
;;;; Like DO-UNARY-BIT-BASH, but we only handle objects that are at
;;;; least byte in size. The offsets and lengths are byte offsets and
;;;; lengths, instead of bits.
(declaim (inline do-unary-byte-bash))
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
(defun do-unary-byte-bash (src src-offset dst dst-offset length
dst-ref-fn dst-set-fn src-ref-fn)
(declare (type offset src-offset dst-offset length)
(type function dst-ref-fn dst-set-fn src-ref-fn))
(multiple-value-bind (dst-word-offset dst-byte-offset)
(floor dst-offset unit-bytes)
(declare (type word-offset dst-word-offset)
(type byte-offset dst-byte-offset))
(multiple-value-bind (src-word-offset src-byte-offset)
(floor src-offset unit-bytes)
(declare (type word-offset src-word-offset)
(type byte-offset src-byte-offset))
(cond
((<= (+ dst-byte-offset length) unit-bytes)
;; We are only writing one word, so it doesn't matter what order
;; we do it in. But we might be reading from multiple words, so take
;; care.
(cond
((zerop length)
;; Actually, we aren't even writing one word. This is real easy.
)
((= length unit-bytes)
;; dst-byte-offset must be equal to zero, or we would be writing
;; multiple words. If src-byte-offset is also zero, then we
;; just transfer the single word. Otherwise we have to extract bits
;; from two src words.
(funcall dst-set-fn dst dst-word-offset
(if (zerop src-byte-offset)
(funcall src-ref-fn src src-word-offset)
(32bit-logical-or
(shift-towards-start
(funcall src-ref-fn src src-word-offset)
(* vm:byte-bits src-byte-offset))
(shift-towards-end
(funcall src-ref-fn src (1+ src-word-offset))
(* vm:byte-bits (- src-byte-offset)))))))
(t
;; We are only writing some portion of the dst word, so we need to
;; preserve the extra bits. Also, we still don't know if we need
;; one or two source words.
(let ((mask (shift-towards-end (start-mask (* vm:byte-bits length))
(* vm:byte-bits dst-byte-offset)))
(orig (funcall dst-ref-fn dst dst-word-offset))
(value
(if (> src-byte-offset dst-byte-offset)
;; The source starts further into the word than does
;; the dst, so the source could extend into the next
;; word. If it does, we have to merge the two words,
;; and if not, we can just shift the first word.
(let ((src-bit-shift (* vm:byte-bits (- src-byte-offset dst-byte-offset))))
(if (> (+ src-byte-offset length) unit-bytes)
(32bit-logical-or
(shift-towards-start
(funcall src-ref-fn src src-word-offset)
src-bit-shift)
(shift-towards-end
(funcall src-ref-fn src (1+ src-word-offset))
(- src-bit-shift)))
(shift-towards-start
(funcall src-ref-fn src src-word-offset)
src-bit-shift)))
;; The dst starts further into the word than does the
;; source, so we know the source can't extend into
;; a second word (or else the dst would too, and we
;; wouldn't be in this branch).
(shift-towards-end
(funcall src-ref-fn src src-word-offset)
(* vm:byte-bits (- dst-byte-offset src-byte-offset))))))
(declare (type unit mask orig value))
;; Replace the dst word.
(funcall dst-set-fn dst dst-word-offset
(32bit-logical-or
(32bit-logical-and value mask)
(32bit-logical-andc2 orig mask)))))))
((= src-byte-offset dst-byte-offset)
;; The source and dst are aligned, so we don't need to shift
;; anything. But we have to pick the direction of the loop
;; in case the source and dst are really the same thing.
(multiple-value-bind (words final-bytes)
(floor (+ dst-byte-offset length) unit-bytes)
(declare (type word-offset words) (type byte-offset final-bytes))
(let ((interior (floor (- length final-bytes) unit-bytes)))
(declare (type word-offset interior))
(cond
((<= dst-offset src-offset)
;; We need to loop from left to right
(unless (zerop dst-byte-offset)
;; We are only writing part of the first word, so mask off the
;; bits we want to preserve.
(let ((mask (end-mask (- dst-byte-offset)))
(orig (funcall dst-ref-fn dst dst-word-offset))
(value (funcall src-ref-fn src src-word-offset)))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
(32bit-logical-or (32bit-logical-and value mask)
(32bit-logical-andc2 orig mask))))
(incf src-word-offset)
(incf dst-word-offset))
;; Just copy the interior words.
(dotimes (i interior)
(funcall dst-set-fn dst dst-word-offset
(funcall src-ref-fn src src-word-offset))
(incf src-word-offset)
(incf dst-word-offset))
(unless (zerop final-bytes)
;; We are only writing part of the last word.
(let ((mask (start-mask (* vm:byte-bits final-bytes)))
(orig (funcall dst-ref-fn dst dst-word-offset))
(value (funcall src-ref-fn src src-word-offset)))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
(32bit-logical-or
(32bit-logical-and value mask)
(32bit-logical-andc2 orig mask))))))
(t
;; We need to loop from right to left.
(incf dst-word-offset words)
(incf src-word-offset words)
(unless (zerop final-bytes)
(let ((mask (start-mask (* vm:byte-bits final-bytes)))
(orig (funcall dst-ref-fn dst dst-word-offset))
(value (funcall src-ref-fn src src-word-offset)))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
(32bit-logical-or
(32bit-logical-and value mask)
(32bit-logical-andc2 orig mask)))))
(dotimes (i interior)
(decf src-word-offset)
(decf dst-word-offset)
(funcall dst-set-fn dst dst-word-offset
(funcall src-ref-fn src src-word-offset)))
(unless (zerop dst-byte-offset)
(decf src-word-offset)
(decf dst-word-offset)
(let ((mask (end-mask (* vm:byte-bits (- dst-byte-offset))))
(orig (funcall dst-ref-fn dst dst-word-offset))
(value (funcall src-ref-fn src src-word-offset)))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
(32bit-logical-or
(32bit-logical-and value mask)
(32bit-logical-andc2 orig mask))))))))))
(t
;; They aren't aligned.
(multiple-value-bind (words final-bytes)
(floor (+ dst-byte-offset length) unit-bytes)
(declare (type word-offset words) (type byte-offset final-bytes))
(let ((src-shift (mod (- src-byte-offset dst-byte-offset) unit-bytes))
(interior (floor (- length final-bytes) unit-bytes)))
(declare (type byte-offset src-shift)
(type word-offset interior))
(cond
((<= dst-offset src-offset)
;; We need to loop from left to right
(let ((prev 0)
(next (funcall src-ref-fn src src-word-offset)))
(declare (type unit prev next))
(flet ((get-next-src ()
(setf prev next)
(setf next (funcall src-ref-fn src
(incf src-word-offset)))))
(declare (inline get-next-src))
(unless (zerop dst-byte-offset)
(when (> src-byte-offset dst-byte-offset)
(get-next-src))
(let ((mask (end-mask (* vm:byte-bits (- dst-byte-offset))))
(orig (funcall dst-ref-fn dst dst-word-offset))
(value (32bit-logical-or
(shift-towards-start prev (* vm:byte-bits src-shift))
(shift-towards-end next (* vm:byte-bits (- src-shift))))))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
(32bit-logical-or
(32bit-logical-and value mask)
(32bit-logical-andc2 orig mask)))
(incf dst-word-offset)))
(dotimes (i interior)
(get-next-src)
(let ((value (32bit-logical-or
(shift-towards-end next (* vm:byte-bits (- src-shift)))
(shift-towards-start prev (* vm:byte-bits src-shift)))))
(declare (type unit value))
(funcall dst-set-fn dst dst-word-offset value)
(incf dst-word-offset)))
(unless (zerop final-bytes)
(let ((value
(if (> (+ final-bytes src-shift) unit-bytes)
(progn
(get-next-src)
(32bit-logical-or
(shift-towards-end next (* vm:byte-bits (- src-shift)))
(shift-towards-start prev (* vm:byte-bits src-shift))))
(shift-towards-start next (* vm:byte-bits src-shift))))
(mask (start-mask (* vm:byte-bits final-bytes)))
(orig (funcall dst-ref-fn dst dst-word-offset)))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
(32bit-logical-or
(32bit-logical-and value mask)
(32bit-logical-andc2 orig mask))))))))
(t
;; We need to loop from right to left.
(incf dst-word-offset words)
(incf src-word-offset
(1- (ceiling (+ src-byte-offset length) unit-bytes)))
(let ((next 0)
(prev (funcall src-ref-fn src src-word-offset)))
(declare (type unit prev next))
(flet ((get-next-src ()
(setf next prev)
(setf prev (funcall src-ref-fn src
(decf src-word-offset)))))
(declare (inline get-next-src))
(unless (zerop final-bytes)
(when (> final-bytes (- unit-bytes src-shift))
(get-next-src))
(let ((value (32bit-logical-or
(shift-towards-end next (* vm:byte-bits (- src-shift)))
(shift-towards-start prev (* vm:byte-bits src-shift))))
(mask (start-mask (* vm:byte-bits final-bytes)))
(orig (funcall dst-ref-fn dst dst-word-offset)))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
(32bit-logical-or
(32bit-logical-and value mask)
(32bit-logical-andc2 orig mask)))))
(decf dst-word-offset)
(dotimes (i interior)
(get-next-src)
(let ((value (32bit-logical-or
(shift-towards-end next (* vm:byte-bits (- src-shift)))
(shift-towards-start prev (* vm:byte-bits src-shift)))))
(declare (type unit value))
(funcall dst-set-fn dst dst-word-offset value)
(decf dst-word-offset)))
(unless (zerop dst-byte-offset)
(if (> src-byte-offset dst-byte-offset)
(get-next-src)
(setf next prev prev 0))
(let ((mask (end-mask (* vm:byte-bits (- dst-byte-offset))))
(orig (funcall dst-ref-fn dst dst-word-offset))
(value (32bit-logical-or
(shift-towards-start prev (* vm:byte-bits src-shift))
(shift-towards-end next (* vm:byte-bits (- src-shift))))))
(declare (type unit mask orig value))
(funcall dst-set-fn dst dst-word-offset
(32bit-logical-or
(32bit-logical-and value mask)
(32bit-logical-andc2 orig mask)))))))))))))))
(undefined-value))
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
;;;; The actual bashers.
(defun bit-bash-fill (value dst dst-offset length)
(declare (type unit value) (type offset dst-offset length))
(locally
(declare (optimize (speed 3) (safety 0)))
(do-constant-bit-bash dst dst-offset length value
#'%raw-bits #'%set-raw-bits)))
(defun system-area-fill (value dst dst-offset length)
(declare (type unit value) (type offset dst-offset length))
(locally
(declare (optimize (speed 3) (safety 0)))
(multiple-value-bind (dst dst-offset)
(fix-sap-and-offset dst dst-offset)
(do-constant-bit-bash dst dst-offset length value
#'word-sap-ref #'%set-word-sap-ref))))
(defun bit-bash-copy (src src-offset dst dst-offset length)
(declare (type offset src-offset dst-offset length))
(locally
(declare (optimize (speed 3) (safety 0))
(inline do-unary-bit-bash))
(do-unary-bit-bash src src-offset dst dst-offset length
#'%raw-bits #'%set-raw-bits #'%raw-bits)))
(defun byte-bash-copy (src src-offset dst dst-offset length)
(declare (type offset src-offset dst-offset length))
(locally
(declare (optimize (speed 3) (safety 0))
(inline do-unary-bit-bash))
(do-unary-byte-bash src src-offset dst dst-offset length
#'%raw-bits #'%set-raw-bits #'%raw-bits)))
(defun system-area-copy (src src-offset dst dst-offset length)
(declare (type offset src-offset dst-offset length))
(locally
(declare (optimize (speed 3) (safety 0)))
(multiple-value-bind (src src-offset)
(fix-sap-and-offset src src-offset)
(declare (type system-area-pointer src))
(multiple-value-bind (dst dst-offset)
(fix-sap-and-offset dst dst-offset)
(declare (type system-area-pointer dst))
(do-unary-bit-bash src src-offset dst dst-offset length
#'word-sap-ref #'%set-word-sap-ref
#'word-sap-ref)))))
(defun copy-to-system-area (src src-offset dst dst-offset length)
(declare (type offset src-offset dst-offset length))
(locally
(declare (optimize (speed 3) (safety 0)))
(multiple-value-bind (dst dst-offset)
(fix-sap-and-offset dst dst-offset)
(do-unary-bit-bash src src-offset dst dst-offset length
#'word-sap-ref #'%set-word-sap-ref #'%raw-bits))))
(defun copy-from-system-area (src src-offset dst dst-offset length)
(declare (type offset src-offset dst-offset length))
(locally
(declare (optimize (speed 3) (safety 0)))
(multiple-value-bind (src src-offset)
(fix-sap-and-offset src src-offset)
(do-unary-bit-bash src src-offset dst dst-offset length
#'%raw-bits #'%set-raw-bits #'word-sap-ref))))