0.7.13.3
[sbcl.git] / src / code / bit-bash.lisp
1 ;;;; functions to implement bitblt-ish operations
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!VM")
13 \f
14 ;;;; constants and types
15
16 ;;; the number of bits to process at a time
17 (defconstant unit-bits n-word-bits)
18
19 ;;; the maximum number of bits that can be dealt with in a single call
20 (defconstant max-bits (ash most-positive-fixnum -2))
21
22 (deftype unit ()
23   `(unsigned-byte ,unit-bits))
24
25 (deftype offset ()
26   `(integer 0 ,max-bits))
27
28 (deftype bit-offset ()
29   `(integer 0 (,unit-bits)))
30
31 (deftype bit-count ()
32   `(integer 1 (,unit-bits)))
33
34 (deftype word-offset ()
35   `(integer 0 (,(ceiling max-bits unit-bits))))
36 \f
37 ;;;; support routines
38
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)
43              `(defun ,name ,args
44                 (,name ,@args))))
45   (def 32bit-logical-not x)
46   (def 32bit-logical-and x y)
47   (def 32bit-logical-or x y)
48   (def 32bit-logical-xor x y)
49   (def 32bit-logical-nor x y)
50   (def 32bit-logical-eqv x y)
51   (def 32bit-logical-nand x y)
52   (def 32bit-logical-andc1 x y)
53   (def 32bit-logical-andc2 x y)
54   (def 32bit-logical-orc1 x y)
55   (def 32bit-logical-orc2 x y))
56
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
60 ;;; is a right-shift.
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))
65     (if (zerop count)
66         number
67         (ecase sb!c:*backend-byte-order*
68           (:big-endian
69            (ash (ldb (byte (- unit-bits count) 0) number) count))
70           (:little-endian
71            (ash number (- count)))))))
72
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))
80     (if (zerop count)
81         number
82         (ecase sb!c:*backend-byte-order*
83           (:big-endian
84            (ash number (- count)))
85           (:little-endian
86            (ash (ldb (byte (- unit-bits count) 0) number) count))))))
87
88 #!-sb-fluid (declaim (inline start-mask end-mask fix-sap-and-offset))
89
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)))
97
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)))
105
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)
109            (type index offset)
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) n-byte-bits) offset))))
115
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)
119            (type index offset)
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)
125            (type index offset)
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))
130 \f
131 ;;;; CONSTANT-BIT-BASH
132
133 ;;; Fill DST with VALUE starting at DST-OFFSET and continuing for
134 ;;; LENGTH bits.
135 #!-sb-fluid (declaim (inline constant-bit-bash))
136 (defun 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))
146       (if (zerop words)
147           (unless (zerop length)
148             (funcall dst-set-fn dst dst-word-offset
149                      (if (= length unit-bits)
150                          value
151                          (let ((mask (shift-towards-end (start-mask length)
152                                                         dst-bit-offset)))
153                            (declare (type unit mask))
154                            (32bit-logical-or
155                             (32bit-logical-and value mask)
156                             (32bit-logical-andc2
157                              (funcall dst-ref-fn dst dst-word-offset)
158                              mask))))))
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
164                          (32bit-logical-or
165                           (32bit-logical-and value mask)
166                           (32bit-logical-andc2
167                            (funcall dst-ref-fn dst dst-word-offset)
168                            mask))))
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
177                          (32bit-logical-or
178                           (32bit-logical-and value mask)
179                           (32bit-logical-andc2
180                            (funcall dst-ref-fn dst dst-word-offset)
181                            mask)))))))))
182   (values))
183 \f
184 ;;;; UNARY-BIT-BASH
185
186 #!-sb-fluid (declaim (inline unary-bit-bash))
187 (defun unary-bit-bash (src src-offset dst dst-offset length
188                            dst-ref-fn dst-set-fn src-ref-fn)
189   ;; FIXME: Declaring these bit indices to be of type OFFSET, then
190   ;; using the inline expansion in SPEED 3 SAFETY 0 functions, is not
191   ;; a good thing. At the very least, we should make sure that the
192   ;; type (overflow) checks get done. Better would be to avoid
193   ;; using bit indices, and to use 32-bit unsigneds instead, and/or
194   ;; to call out to things like memmove(3) for big moves.
195   (declare (type offset src-offset dst-offset length)
196            (type function dst-ref-fn dst-set-fn src-ref-fn))
197   (multiple-value-bind (dst-word-offset dst-bit-offset)
198       (floor dst-offset unit-bits)
199     (declare (type word-offset dst-word-offset)
200              (type bit-offset dst-bit-offset))
201     (multiple-value-bind (src-word-offset src-bit-offset)
202         (floor src-offset unit-bits)
203       (declare (type word-offset src-word-offset)
204                (type bit-offset src-bit-offset))
205       (cond
206        ((<= (+ dst-bit-offset length) unit-bits)
207         ;; We are only writing one word, so it doesn't matter what
208         ;; order we do it in. But we might be reading from multiple
209         ;; words, so take care.
210         (cond
211          ((zerop length)
212           ;; Actually, we aren't even writing one word. This is really easy.
213           )
214          ((= length unit-bits)
215           ;; DST-BIT-OFFSET must be equal to zero, or we would be
216           ;; writing multiple words. If SRC-BIT-OFFSET is also zero,
217           ;; then we just transfer the single word. Otherwise we have
218           ;; to extract bits from two src words.
219           (funcall dst-set-fn dst dst-word-offset
220                    (if (zerop src-bit-offset)
221                        (funcall src-ref-fn src src-word-offset)
222                        (32bit-logical-or
223                         (shift-towards-start
224                          (funcall src-ref-fn src src-word-offset)
225                          src-bit-offset)
226                         (shift-towards-end
227                          (funcall src-ref-fn src (1+ src-word-offset))
228                          (- src-bit-offset))))))
229          (t
230           ;; We are only writing some portion of the dst word, so we
231           ;; need to preserve the extra bits. Also, we still don't
232           ;; know whether we need one or two source words.
233           (let ((mask (shift-towards-end (start-mask length) dst-bit-offset))
234                 (orig (funcall dst-ref-fn dst dst-word-offset))
235                 (value
236                  (if (> src-bit-offset dst-bit-offset)
237                      ;; The source starts further into the word than
238                      ;; does the dst, so the source could extend into
239                      ;; the next word. If it does, we have to merge
240                      ;; the two words, and if not, we can just shift
241                      ;; the first word.
242                      (let ((src-bit-shift (- src-bit-offset dst-bit-offset)))
243                        (if (> (+ src-bit-offset length) unit-bits)
244                            (32bit-logical-or
245                             (shift-towards-start
246                              (funcall src-ref-fn src src-word-offset)
247                              src-bit-shift)
248                             (shift-towards-end
249                              (funcall src-ref-fn src (1+ src-word-offset))
250                              (- src-bit-shift)))
251                            (shift-towards-start
252                             (funcall src-ref-fn src src-word-offset)
253                             src-bit-shift)))
254                      ;; The dst starts further into the word than does
255                      ;; the source, so we know the source can not
256                      ;; extend into a second word (or else the dst
257                      ;; would too, and we wouldn't be in this branch.
258                      (shift-towards-end
259                       (funcall src-ref-fn src src-word-offset)
260                       (- dst-bit-offset src-bit-offset)))))
261             (declare (type unit mask orig value))
262             ;; Replace the dst word.
263             (funcall dst-set-fn dst dst-word-offset
264                      (32bit-logical-or
265                       (32bit-logical-and value mask)
266                       (32bit-logical-andc2 orig mask)))))))
267        ((= src-bit-offset dst-bit-offset)
268         ;; The source and dst are aligned, so we don't need to shift
269         ;; anything. But we have to pick the direction of the loop in
270         ;; case the source and dst are really the same thing.
271         (multiple-value-bind (words final-bits)
272             (floor (+ dst-bit-offset length) unit-bits)
273           (declare (type word-offset words) (type bit-offset final-bits))
274           (let ((interior (floor (- length final-bits) unit-bits)))
275             (declare (type word-offset interior))
276             (cond
277              ((<= dst-offset src-offset)
278               ;; We need to loop from left to right
279               (unless (zerop dst-bit-offset)
280                 ;; We are only writing part of the first word, so mask
281                 ;; off the bits we want to preserve.
282                 (let ((mask (end-mask (- dst-bit-offset)))
283                       (orig (funcall dst-ref-fn dst dst-word-offset))
284                       (value (funcall src-ref-fn src src-word-offset)))
285                   (declare (type unit mask orig value))
286                   (funcall dst-set-fn dst dst-word-offset
287                            (32bit-logical-or (32bit-logical-and value mask)
288                                              (32bit-logical-andc2 orig mask))))
289                 (incf src-word-offset)
290                 (incf dst-word-offset))
291               ;; Just copy the interior words.
292               (dotimes (i interior)
293                 (funcall dst-set-fn dst dst-word-offset
294                          (funcall src-ref-fn src src-word-offset))
295                 (incf src-word-offset)
296                 (incf dst-word-offset))
297               (unless (zerop final-bits)
298                 ;; We are only writing part of the last word.
299                 (let ((mask (start-mask final-bits))
300                       (orig (funcall dst-ref-fn dst dst-word-offset))
301                       (value (funcall src-ref-fn src src-word-offset)))
302                   (declare (type unit mask orig value))
303                   (funcall dst-set-fn dst dst-word-offset
304                            (32bit-logical-or
305                             (32bit-logical-and value mask)
306                             (32bit-logical-andc2 orig mask))))))
307              (t
308               ;; We need to loop from right to left.
309               (incf dst-word-offset words)
310               (incf src-word-offset words)
311               (unless (zerop final-bits)
312                 (let ((mask (start-mask final-bits))
313                       (orig (funcall dst-ref-fn dst dst-word-offset))
314                       (value (funcall src-ref-fn src src-word-offset)))
315                   (declare (type unit mask orig value))
316                   (funcall dst-set-fn dst dst-word-offset
317                            (32bit-logical-or
318                             (32bit-logical-and value mask)
319                             (32bit-logical-andc2 orig mask)))))
320               (dotimes (i interior)
321                 (decf src-word-offset)
322                 (decf dst-word-offset)
323                 (funcall dst-set-fn dst dst-word-offset
324                          (funcall src-ref-fn src src-word-offset)))
325               (unless (zerop dst-bit-offset)
326                 (decf src-word-offset)
327                 (decf dst-word-offset)
328                 (let ((mask (end-mask (- dst-bit-offset)))
329                       (orig (funcall dst-ref-fn dst dst-word-offset))
330                       (value (funcall src-ref-fn src src-word-offset)))
331                   (declare (type unit mask orig value))
332                   (funcall dst-set-fn dst dst-word-offset
333                            (32bit-logical-or
334                             (32bit-logical-and value mask)
335                             (32bit-logical-andc2 orig mask))))))))))
336        (t
337         ;; They aren't aligned.
338         (multiple-value-bind (words final-bits)
339             (floor (+ dst-bit-offset length) unit-bits)
340           (declare (type word-offset words) (type bit-offset final-bits))
341           (let ((src-shift (mod (- src-bit-offset dst-bit-offset) unit-bits))
342                 (interior (floor (- length final-bits) unit-bits)))
343             (declare (type bit-offset src-shift)
344                      (type word-offset interior))
345             (cond
346              ((<= dst-offset src-offset)
347               ;; We need to loop from left to right
348               (let ((prev 0)
349                     (next (funcall src-ref-fn src src-word-offset)))
350                 (declare (type unit prev next))
351                 (flet ((get-next-src ()
352                          (setf prev next)
353                          (setf next (funcall src-ref-fn src
354                                              (incf src-word-offset)))))
355                   (declare (inline get-next-src))
356                   (unless (zerop dst-bit-offset)
357                     (when (> src-bit-offset dst-bit-offset)
358                       (get-next-src))
359                     (let ((mask (end-mask (- dst-bit-offset)))
360                           (orig (funcall dst-ref-fn dst dst-word-offset))
361                           (value (32bit-logical-or
362                                   (shift-towards-start prev src-shift)
363                                   (shift-towards-end next (- src-shift)))))
364                       (declare (type unit mask orig value))
365                       (funcall dst-set-fn dst dst-word-offset
366                                (32bit-logical-or
367                                 (32bit-logical-and value mask)
368                                 (32bit-logical-andc2 orig mask)))
369                       (incf dst-word-offset)))
370                   (dotimes (i interior)
371                     (get-next-src)
372                     (let ((value (32bit-logical-or
373                                   (shift-towards-end next (- src-shift))
374                                   (shift-towards-start prev src-shift))))
375                       (declare (type unit value))
376                       (funcall dst-set-fn dst dst-word-offset value)
377                       (incf dst-word-offset)))
378                   (unless (zerop final-bits)
379                     (let ((value
380                            (if (> (+ final-bits src-shift) unit-bits)
381                                (progn
382                                  (get-next-src)
383                                  (32bit-logical-or
384                                   (shift-towards-end next (- src-shift))
385                                   (shift-towards-start prev src-shift)))
386                                (shift-towards-start next src-shift)))
387                           (mask (start-mask final-bits))
388                           (orig (funcall dst-ref-fn dst dst-word-offset)))
389                       (declare (type unit mask orig value))
390                       (funcall dst-set-fn dst dst-word-offset
391                                (32bit-logical-or
392                                 (32bit-logical-and value mask)
393                                 (32bit-logical-andc2 orig mask))))))))
394              (t
395               ;; We need to loop from right to left.
396               (incf dst-word-offset words)
397               (incf src-word-offset
398                     (1- (ceiling (+ src-bit-offset length) unit-bits)))
399               (let ((next 0)
400                     (prev (funcall src-ref-fn src src-word-offset)))
401                 (declare (type unit prev next))
402                 (flet ((get-next-src ()
403                          (setf next prev)
404                          (setf prev (funcall src-ref-fn src
405                                              (decf src-word-offset)))))
406                   (declare (inline get-next-src))
407                   (unless (zerop final-bits)
408                     (when (> final-bits (- unit-bits src-shift))
409                       (get-next-src))
410                     (let ((value (32bit-logical-or
411                                   (shift-towards-end next (- src-shift))
412                                   (shift-towards-start prev src-shift)))
413                           (mask (start-mask final-bits))
414                           (orig (funcall dst-ref-fn dst dst-word-offset)))
415                       (declare (type unit mask orig value))
416                       (funcall dst-set-fn dst dst-word-offset
417                                (32bit-logical-or
418                                 (32bit-logical-and value mask)
419                                 (32bit-logical-andc2 orig mask)))))
420                   (decf dst-word-offset)
421                   (dotimes (i interior)
422                     (get-next-src)
423                     (let ((value (32bit-logical-or
424                                   (shift-towards-end next (- src-shift))
425                                   (shift-towards-start prev src-shift))))
426                       (declare (type unit value))
427                       (funcall dst-set-fn dst dst-word-offset value)
428                       (decf dst-word-offset)))
429                   (unless (zerop dst-bit-offset)
430                     (if (> src-bit-offset dst-bit-offset)
431                         (get-next-src)
432                         (setf next prev prev 0))
433                     (let ((mask (end-mask (- dst-bit-offset)))
434                           (orig (funcall dst-ref-fn dst dst-word-offset))
435                           (value (32bit-logical-or
436                                   (shift-towards-start prev src-shift)
437                                   (shift-towards-end next (- src-shift)))))
438                       (declare (type unit mask orig value))
439                       (funcall dst-set-fn dst dst-word-offset
440                                (32bit-logical-or
441                                 (32bit-logical-and value mask)
442                                 (32bit-logical-andc2 orig mask)))))))))))))))
443   (values))
444 \f
445 ;;;; the actual bashers
446
447 (defun bit-bash-fill (value dst dst-offset length)
448   (declare (type unit value) (type offset dst-offset length))
449   (locally
450    (declare (optimize (speed 3) (safety 0)))
451    (constant-bit-bash dst dst-offset length value
452                       #'%raw-bits #'%set-raw-bits)))
453
454 (defun system-area-fill (value dst dst-offset length)
455   (declare (type unit value) (type offset dst-offset length))
456   (locally
457    (declare (optimize (speed 3) (safety 0)))
458    (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
459      (constant-bit-bash dst dst-offset length value
460                         #'word-sap-ref #'%set-word-sap-ref))))
461
462 (defun bit-bash-copy (src src-offset dst dst-offset length)
463   (declare (type offset src-offset dst-offset length))
464   (locally
465    (declare (optimize (speed 3) (safety 0))
466             (inline unary-bit-bash))
467    (unary-bit-bash src src-offset dst dst-offset length
468                    #'%raw-bits #'%set-raw-bits #'%raw-bits)))
469
470 (defun system-area-copy (src src-offset dst dst-offset length)
471   (declare (type offset src-offset dst-offset length))
472   (locally
473    (declare (optimize (speed 3) (safety 0)))
474    (multiple-value-bind (src src-offset) (fix-sap-and-offset src src-offset)
475      (declare (type system-area-pointer src))
476      (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
477        (declare (type system-area-pointer dst))
478        (unary-bit-bash src src-offset dst dst-offset length
479                        #'word-sap-ref #'%set-word-sap-ref
480                        #'word-sap-ref)))))
481
482 (defun copy-to-system-area (src src-offset dst dst-offset length)
483   (declare (type offset src-offset dst-offset length))
484   (locally
485    (declare (optimize (speed 3) (safety 0)))
486    (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
487      (unary-bit-bash src src-offset dst dst-offset length
488                      #'word-sap-ref #'%set-word-sap-ref #'%raw-bits))))
489
490 (defun copy-from-system-area (src src-offset dst dst-offset length)
491   (declare (type offset src-offset dst-offset length))
492   (locally
493    (declare (optimize (speed 3) (safety 0)))
494    (multiple-value-bind (src src-offset) (fix-sap-and-offset src src-offset)
495      (unary-bit-bash src src-offset dst dst-offset length
496                      #'%raw-bits #'%set-raw-bits #'word-sap-ref))))
497
498 ;;; a common idiom for calling COPY-TO-SYSTEM-AREA
499 ;;;
500 ;;; Copy the entire contents of the vector V to memory starting at SAP+OFFSET.
501 (defun copy-byte-vector-to-system-area (bv sap &optional (offset 0))
502   ;; FIXME: There should be a type like SB!VM:BYTE so that we can write this
503   ;; type as (SIMPLE-ARRAY SB!VM:BYTE 1). Except BYTE is an external symbol of
504   ;; package CL, and shadowing it would be too ugly; so maybe SB!VM:VMBYTE?
505   ;; (And then N-BYTE-BITS would be N-VMBYTE-BITS and so forth?)
506   (declare (type (simple-array (unsigned-byte 8) 1) bv))
507   (declare (type system-area-pointer sap))
508   (declare (type fixnum offset))
509   ;; FIXME: Actually it looks as though this, and most other calls to
510   ;; COPY-TO-SYSTEM-AREA, could be written more concisely with
511   ;; %BYTE-BLT. Except that the DST-END-DST-START convention for the
512   ;; length is confusing. Perhaps I could rename %BYTE-BLT to
513   ;; %BYTE-BLIT (and correspondingly rename the corresponding VOP) and
514   ;; replace the DST-END argument with an N-BYTES argument?
515   (copy-to-system-area bv
516                        (* vector-data-offset n-word-bits)
517                        sap
518                        offset
519                        (* (length bv) n-byte-bits)))