0.6.10.21:
[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 (defconstant unit-bits sb!vm:word-bits
17   #!+sb-doc
18   "The number of bits to process at a time.")
19
20 (defconstant max-bits (ash most-positive-fixnum -2)
21   #!+sb-doc
22   "The maximum number of bits that can be delt with during a single call.")
23
24 ;;; FIXME: Do we really need EVAL-WHEN around these DEFTYPEs?
25 (eval-when (:compile-toplevel :load-toplevel :execute)
26
27 (deftype unit ()
28   `(unsigned-byte ,unit-bits))
29
30 (deftype offset ()
31   `(integer 0 ,max-bits))
32
33 (deftype bit-offset ()
34   `(integer 0 (,unit-bits)))
35
36 (deftype bit-count ()
37   `(integer 1 (,unit-bits)))
38
39 (deftype word-offset ()
40   `(integer 0 (,(ceiling max-bits unit-bits))))
41
42 ) ; EVAL-WHEN
43 \f
44 ;;;; support routines
45
46 ;;; A particular implementation must offer either VOPs to translate
47 ;;; these, or DEFTRANSFORMs to convert them into something supported
48 ;;; by the architecture.
49 (macrolet ((def-frob (name &rest args)
50              `(defun ,name ,args
51                 (,name ,@args))))
52   (def-frob 32bit-logical-not x)
53   (def-frob 32bit-logical-and x y)
54   (def-frob 32bit-logical-or x y)
55   (def-frob 32bit-logical-xor x y)
56   (def-frob 32bit-logical-nor x y)
57   (def-frob 32bit-logical-eqv x y)
58   (def-frob 32bit-logical-nand x y)
59   (def-frob 32bit-logical-andc1 x y)
60   (def-frob 32bit-logical-andc2 x y)
61   (def-frob 32bit-logical-orc1 x y)
62   (def-frob 32bit-logical-orc2 x y))
63
64 (defun shift-towards-start (number countoid)
65   #!+sb-doc
66   "Shift NUMBER by the low-order bits of COUNTOID, adding zero bits at
67   the ``end'' and removing bits from the ``start.''  On big-endian
68   machines this is a left-shift and on little-endian machines this is a
69   right-shift."
70   (declare (type unit number) (fixnum countoid))
71   (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) countoid)))
72     (declare (type bit-offset count))
73     (if (zerop count)
74         number
75         (ecase sb!c:*backend-byte-order*
76           (:big-endian
77            (ash (ldb (byte (- unit-bits count) 0) number) count))
78           (:little-endian
79            (ash number (- count)))))))
80
81 (defun shift-towards-end (number count)
82   #!+sb-doc
83   "Shift NUMBER by COUNT bits, adding zero bits at the ``start'' and removing
84   bits from the ``end.''  On big-endian machines this is a right-shift and
85   on little-endian machines this is a left-shift."
86   (declare (type unit number) (fixnum count))
87   (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count)))
88     (declare (type bit-offset count))
89     (if (zerop count)
90         number
91         (ecase sb!c:*backend-byte-order*
92           (:big-endian
93            (ash number (- count)))
94           (:little-endian
95            (ash (ldb (byte (- unit-bits count) 0) number) count))))))
96
97 #!-sb-fluid (declaim (inline start-mask end-mask fix-sap-and-offset))
98 (defun start-mask (count)
99   #!+sb-doc
100   "Produce a mask that contains 1's for the COUNT ``start'' bits and 0's for
101   the remaining ``end'' bits. Only the lower 5 bits of COUNT are significant."
102   (declare (fixnum count))
103   (shift-towards-start (1- (ash 1 unit-bits)) (- count)))
104
105 (defun end-mask (count)
106   #!+sb-doc
107   "Produce a mask that contains 1's for the COUNT ``end'' bits and 0's for
108   the remaining ``start'' bits. Only the lower 5 bits of COUNT are
109   significant."
110   (declare (fixnum count))
111   (shift-towards-end (1- (ash 1 unit-bits)) (- count)))
112
113 (defun fix-sap-and-offset (sap offset)
114   #!+sb-doc
115   "Align the SAP to a word boundary, and update the offset accordingly."
116   (declare (type system-area-pointer sap)
117            (type index offset)
118            (values system-area-pointer index))
119   (let ((address (sap-int sap)))
120     (values (int-sap #!-alpha (32bit-logical-andc2 address 3)
121                      #!+alpha (ash (ash address -2) 2))
122             (+ (* (logand address 3) byte-bits) offset))))
123
124 #!-sb-fluid (declaim (inline word-sap-ref %set-word-sap-ref))
125 (defun word-sap-ref (sap offset)
126   (declare (type system-area-pointer sap)
127            (type index offset)
128            (values (unsigned-byte 32))
129            (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3)))
130   (sap-ref-32 sap (the index (ash offset 2))))
131 (defun %set-word-sap-ref (sap offset value)
132   (declare (type system-area-pointer sap)
133            (type index offset)
134            (type (unsigned-byte 32) value)
135            (values (unsigned-byte 32))
136            (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
137   (setf (sap-ref-32 sap (the index (ash offset 2))) value))
138 \f
139 ;;;; DO-CONSTANT-BIT-BASH
140
141 #!-sb-fluid (declaim (inline do-constant-bit-bash))
142 (defun do-constant-bit-bash (dst dst-offset length value dst-ref-fn dst-set-fn)
143   #!+sb-doc
144   "Fill DST with VALUE starting at DST-OFFSET and continuing for LENGTH bits."
145   (declare (type offset dst-offset) (type unit value)
146            (type function dst-ref-fn dst-set-fn))
147   (multiple-value-bind (dst-word-offset dst-bit-offset)
148       (floor dst-offset unit-bits)
149     (declare (type word-offset dst-word-offset)
150              (type bit-offset dst-bit-offset))
151     (multiple-value-bind (words final-bits)
152         (floor (+ dst-bit-offset length) unit-bits)
153       (declare (type word-offset words) (type bit-offset final-bits))
154       (if (zerop words)
155           (unless (zerop length)
156             (funcall dst-set-fn dst dst-word-offset
157                      (if (= length unit-bits)
158                          value
159                          (let ((mask (shift-towards-end (start-mask length)
160                                                         dst-bit-offset)))
161                            (declare (type unit mask))
162                            (32bit-logical-or
163                             (32bit-logical-and value mask)
164                             (32bit-logical-andc2
165                              (funcall dst-ref-fn dst dst-word-offset)
166                              mask))))))
167           (let ((interior (floor (- length final-bits) unit-bits)))
168             (unless (zerop dst-bit-offset)
169               (let ((mask (end-mask (- dst-bit-offset))))
170                 (declare (type unit mask))
171                 (funcall dst-set-fn dst dst-word-offset
172                          (32bit-logical-or
173                           (32bit-logical-and value mask)
174                           (32bit-logical-andc2
175                            (funcall dst-ref-fn dst dst-word-offset)
176                            mask))))
177               (incf dst-word-offset))
178             (dotimes (i interior)
179               (funcall dst-set-fn dst dst-word-offset value)
180               (incf dst-word-offset))
181             (unless (zerop final-bits)
182               (let ((mask (start-mask final-bits)))
183                 (declare (type unit mask))
184                 (funcall dst-set-fn dst dst-word-offset
185                          (32bit-logical-or
186                           (32bit-logical-and value mask)
187                           (32bit-logical-andc2
188                            (funcall dst-ref-fn dst dst-word-offset)
189                            mask)))))))))
190   (values))
191 \f
192 ;;;; DO-UNARY-BIT-BASH
193
194 #!-sb-fluid (declaim (inline do-unary-bit-bash))
195 (defun do-unary-bit-bash (src src-offset dst dst-offset length
196                               dst-ref-fn dst-set-fn src-ref-fn)
197   (declare (type offset src-offset dst-offset length)
198            (type function dst-ref-fn dst-set-fn src-ref-fn))
199   (multiple-value-bind (dst-word-offset dst-bit-offset)
200       (floor dst-offset unit-bits)
201     (declare (type word-offset dst-word-offset)
202              (type bit-offset dst-bit-offset))
203     (multiple-value-bind (src-word-offset src-bit-offset)
204         (floor src-offset unit-bits)
205       (declare (type word-offset src-word-offset)
206                (type bit-offset src-bit-offset))
207       (cond
208        ((<= (+ dst-bit-offset length) unit-bits)
209         ;; We are only writing one word, so it doesn't matter what order
210         ;; we do it in. But we might be reading from multiple words, so take
211         ;; care.
212         (cond
213          ((zerop length)
214           ;; Actually, we aren't even writing one word. This is really easy.
215           )
216          ((= length unit-bits)
217           ;; DST-BIT-OFFSET must be equal to zero, or we would be writing
218           ;; multiple words. If SRC-BIT-OFFSET is also zero, then we
219           ;; just transfer the single word. Otherwise we have to extract bits
220           ;; from two src words.
221           (funcall dst-set-fn dst dst-word-offset
222                    (if (zerop src-bit-offset)
223                        (funcall src-ref-fn src src-word-offset)
224                        (32bit-logical-or
225                         (shift-towards-start
226                          (funcall src-ref-fn src src-word-offset)
227                          src-bit-offset)
228                         (shift-towards-end
229                          (funcall src-ref-fn src (1+ src-word-offset))
230                          (- src-bit-offset))))))
231          (t
232           ;; We are only writing some portion of the dst word, so we need to
233           ;; preserve the extra bits. Also, we still don't know whether we need
234           ;; one or two source words.
235           (let ((mask (shift-towards-end (start-mask length) dst-bit-offset))
236                 (orig (funcall dst-ref-fn dst dst-word-offset))
237                 (value
238                  (if (> src-bit-offset dst-bit-offset)
239                      ;; The source starts further into the word than does
240                      ;; the dst, so the source could extend into the next
241                      ;; word. If it does, we have to merge the two words,
242                      ;; and if not, we can just shift the first word.
243                      (let ((src-bit-shift (- src-bit-offset dst-bit-offset)))
244                        (if (> (+ src-bit-offset length) unit-bits)
245                            (32bit-logical-or
246                             (shift-towards-start
247                              (funcall src-ref-fn src src-word-offset)
248                              src-bit-shift)
249                             (shift-towards-end
250                              (funcall src-ref-fn src (1+ src-word-offset))
251                              (- src-bit-shift)))
252                            (shift-towards-start
253                             (funcall src-ref-fn src src-word-offset)
254                             src-bit-shift)))
255                      ;; The dst starts further into the word than does the
256                      ;; source, so we know the source can not extend into
257                      ;; a second word (or else the dst would too, and we
258                      ;; wouldn't be in this branch.
259                      (shift-towards-end
260                       (funcall src-ref-fn src src-word-offset)
261                       (- dst-bit-offset src-bit-offset)))))
262             (declare (type unit mask orig value))
263             ;; Replace the dst word.
264             (funcall dst-set-fn dst dst-word-offset
265                      (32bit-logical-or
266                       (32bit-logical-and value mask)
267                       (32bit-logical-andc2 orig mask)))))))
268        ((= src-bit-offset dst-bit-offset)
269         ;; The source and dst are aligned, so we don't need to shift
270         ;; anything. But we have to pick the direction of the loop
271         ;; in case the source and dst are really the same thing.
272         (multiple-value-bind (words final-bits)
273             (floor (+ dst-bit-offset length) unit-bits)
274           (declare (type word-offset words) (type bit-offset final-bits))
275           (let ((interior (floor (- length final-bits) unit-bits)))
276             (declare (type word-offset interior))
277             (cond
278              ((<= dst-offset src-offset)
279               ;; We need to loop from left to right
280               (unless (zerop dst-bit-offset)
281                 ;; We are only writing part of the first word, so mask off the
282                 ;; bits we want to preserve.
283                 (let ((mask (end-mask (- dst-bit-offset)))
284                       (orig (funcall dst-ref-fn dst dst-word-offset))
285                       (value (funcall src-ref-fn src src-word-offset)))
286                   (declare (type unit mask orig value))
287                   (funcall dst-set-fn dst dst-word-offset
288                            (32bit-logical-or (32bit-logical-and value mask)
289                                              (32bit-logical-andc2 orig mask))))
290                 (incf src-word-offset)
291                 (incf dst-word-offset))
292               ;; Just copy the interior words.
293               (dotimes (i interior)
294                 (funcall dst-set-fn dst dst-word-offset
295                          (funcall src-ref-fn src src-word-offset))
296                 (incf src-word-offset)
297                 (incf dst-word-offset))
298               (unless (zerop final-bits)
299                 ;; We are only writing part of the last word.
300                 (let ((mask (start-mask final-bits))
301                       (orig (funcall dst-ref-fn dst dst-word-offset))
302                       (value (funcall src-ref-fn src src-word-offset)))
303                   (declare (type unit mask orig value))
304                   (funcall dst-set-fn dst dst-word-offset
305                            (32bit-logical-or
306                             (32bit-logical-and value mask)
307                             (32bit-logical-andc2 orig mask))))))
308              (t
309               ;; We need to loop from right to left.
310               (incf dst-word-offset words)
311               (incf src-word-offset words)
312               (unless (zerop final-bits)
313                 (let ((mask (start-mask final-bits))
314                       (orig (funcall dst-ref-fn dst dst-word-offset))
315                       (value (funcall src-ref-fn src src-word-offset)))
316                   (declare (type unit mask orig value))
317                   (funcall dst-set-fn dst dst-word-offset
318                            (32bit-logical-or
319                             (32bit-logical-and value mask)
320                             (32bit-logical-andc2 orig mask)))))
321               (dotimes (i interior)
322                 (decf src-word-offset)
323                 (decf dst-word-offset)
324                 (funcall dst-set-fn dst dst-word-offset
325                          (funcall src-ref-fn src src-word-offset)))
326               (unless (zerop dst-bit-offset)
327                 (decf src-word-offset)
328                 (decf dst-word-offset)
329                 (let ((mask (end-mask (- dst-bit-offset)))
330                       (orig (funcall dst-ref-fn dst dst-word-offset))
331                       (value (funcall src-ref-fn src src-word-offset)))
332                   (declare (type unit mask orig value))
333                   (funcall dst-set-fn dst dst-word-offset
334                            (32bit-logical-or
335                             (32bit-logical-and value mask)
336                             (32bit-logical-andc2 orig mask))))))))))
337        (t
338         ;; They aren't aligned.
339         (multiple-value-bind (words final-bits)
340             (floor (+ dst-bit-offset length) unit-bits)
341           (declare (type word-offset words) (type bit-offset final-bits))
342           (let ((src-shift (mod (- src-bit-offset dst-bit-offset) unit-bits))
343                 (interior (floor (- length final-bits) unit-bits)))
344             (declare (type bit-offset src-shift)
345                      (type word-offset interior))
346             (cond
347              ((<= dst-offset src-offset)
348               ;; We need to loop from left to right
349               (let ((prev 0)
350                     (next (funcall src-ref-fn src src-word-offset)))
351                 (declare (type unit prev next))
352                 (flet ((get-next-src ()
353                          (setf prev next)
354                          (setf next (funcall src-ref-fn src
355                                              (incf src-word-offset)))))
356                   (declare (inline get-next-src))
357                   (unless (zerop dst-bit-offset)
358                     (when (> src-bit-offset dst-bit-offset)
359                       (get-next-src))
360                     (let ((mask (end-mask (- dst-bit-offset)))
361                           (orig (funcall dst-ref-fn dst dst-word-offset))
362                           (value (32bit-logical-or
363                                   (shift-towards-start prev src-shift)
364                                   (shift-towards-end next (- src-shift)))))
365                       (declare (type unit mask orig value))
366                       (funcall dst-set-fn dst dst-word-offset
367                                (32bit-logical-or
368                                 (32bit-logical-and value mask)
369                                 (32bit-logical-andc2 orig mask)))
370                       (incf dst-word-offset)))
371                   (dotimes (i interior)
372                     (get-next-src)
373                     (let ((value (32bit-logical-or
374                                   (shift-towards-end next (- src-shift))
375                                   (shift-towards-start prev src-shift))))
376                       (declare (type unit value))
377                       (funcall dst-set-fn dst dst-word-offset value)
378                       (incf dst-word-offset)))
379                   (unless (zerop final-bits)
380                     (let ((value
381                            (if (> (+ final-bits src-shift) unit-bits)
382                                (progn
383                                  (get-next-src)
384                                  (32bit-logical-or
385                                   (shift-towards-end next (- src-shift))
386                                   (shift-towards-start prev src-shift)))
387                                (shift-towards-start next src-shift)))
388                           (mask (start-mask final-bits))
389                           (orig (funcall dst-ref-fn dst dst-word-offset)))
390                       (declare (type unit mask orig value))
391                       (funcall dst-set-fn dst dst-word-offset
392                                (32bit-logical-or
393                                 (32bit-logical-and value mask)
394                                 (32bit-logical-andc2 orig mask))))))))
395              (t
396               ;; We need to loop from right to left.
397               (incf dst-word-offset words)
398               (incf src-word-offset
399                     (1- (ceiling (+ src-bit-offset length) unit-bits)))
400               (let ((next 0)
401                     (prev (funcall src-ref-fn src src-word-offset)))
402                 (declare (type unit prev next))
403                 (flet ((get-next-src ()
404                          (setf next prev)
405                          (setf prev (funcall src-ref-fn src
406                                              (decf src-word-offset)))))
407                   (declare (inline get-next-src))
408                   (unless (zerop final-bits)
409                     (when (> final-bits (- unit-bits src-shift))
410                       (get-next-src))
411                     (let ((value (32bit-logical-or
412                                   (shift-towards-end next (- src-shift))
413                                   (shift-towards-start prev src-shift)))
414                           (mask (start-mask final-bits))
415                           (orig (funcall dst-ref-fn dst dst-word-offset)))
416                       (declare (type unit mask orig value))
417                       (funcall dst-set-fn dst dst-word-offset
418                                (32bit-logical-or
419                                 (32bit-logical-and value mask)
420                                 (32bit-logical-andc2 orig mask)))))
421                   (decf dst-word-offset)
422                   (dotimes (i interior)
423                     (get-next-src)
424                     (let ((value (32bit-logical-or
425                                   (shift-towards-end next (- src-shift))
426                                   (shift-towards-start prev src-shift))))
427                       (declare (type unit value))
428                       (funcall dst-set-fn dst dst-word-offset value)
429                       (decf dst-word-offset)))
430                   (unless (zerop dst-bit-offset)
431                     (if (> src-bit-offset dst-bit-offset)
432                         (get-next-src)
433                         (setf next prev prev 0))
434                     (let ((mask (end-mask (- dst-bit-offset)))
435                           (orig (funcall dst-ref-fn dst dst-word-offset))
436                           (value (32bit-logical-or
437                                   (shift-towards-start prev src-shift)
438                                   (shift-towards-end next (- src-shift)))))
439                       (declare (type unit mask orig value))
440                       (funcall dst-set-fn dst dst-word-offset
441                                (32bit-logical-or
442                                 (32bit-logical-and value mask)
443                                 (32bit-logical-andc2 orig mask)))))))))))))))
444   (values))
445 \f
446 ;;;; the actual bashers
447
448 (defun bit-bash-fill (value dst dst-offset length)
449   (declare (type unit value) (type offset dst-offset length))
450   (locally
451    (declare (optimize (speed 3) (safety 0)))
452    (do-constant-bit-bash dst dst-offset length value
453                          #'%raw-bits #'%set-raw-bits)))
454
455 (defun system-area-fill (value dst dst-offset length)
456   (declare (type unit value) (type offset dst-offset length))
457   (locally
458    (declare (optimize (speed 3) (safety 0)))
459    (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
460      (do-constant-bit-bash dst dst-offset length value
461                            #'word-sap-ref #'%set-word-sap-ref))))
462
463 (defun bit-bash-copy (src src-offset dst dst-offset length)
464   (declare (type offset src-offset dst-offset length))
465   (locally
466    (declare (optimize (speed 3) (safety 0))
467             (inline do-unary-bit-bash))
468    (do-unary-bit-bash src src-offset dst dst-offset length
469                       #'%raw-bits #'%set-raw-bits #'%raw-bits)))
470
471 (defun system-area-copy (src src-offset dst dst-offset length)
472   (declare (type offset src-offset dst-offset length))
473   (locally
474    (declare (optimize (speed 3) (safety 0)))
475    (multiple-value-bind (src src-offset) (fix-sap-and-offset src src-offset)
476      (declare (type system-area-pointer src))
477      (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
478        (declare (type system-area-pointer dst))
479        (do-unary-bit-bash src src-offset dst dst-offset length
480                           #'word-sap-ref #'%set-word-sap-ref
481                           #'word-sap-ref)))))
482
483 (defun copy-to-system-area (src src-offset dst dst-offset length)
484   (declare (type offset src-offset dst-offset length))
485   (locally
486    (declare (optimize (speed 3) (safety 0)))
487    (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
488      (do-unary-bit-bash src src-offset dst dst-offset length
489                         #'word-sap-ref #'%set-word-sap-ref #'%raw-bits))))
490
491 (defun copy-from-system-area (src src-offset dst dst-offset length)
492   (declare (type offset src-offset dst-offset length))
493   (locally
494    (declare (optimize (speed 3) (safety 0)))
495    (multiple-value-bind (src src-offset) (fix-sap-and-offset src src-offset)
496      (do-unary-bit-bash src src-offset dst dst-offset length
497                         #'%raw-bits #'%set-raw-bits #'word-sap-ref))))
498
499 ;;; a common idiom for calling COPY-TO-SYSTEM-AREA
500 ;;;
501 ;;; Copy the entire contents of the vector V to memory starting at SAP+OFFSET.
502 (defun copy-byte-vector-to-system-area (bv sap &optional (offset 0))
503   ;; FIXME: There should be a type like SB!VM:BYTE so that we can write this
504   ;; type as (SIMPLE-ARRAY SB!VM:BYTE 1). Except BYTE is an external symbol of
505   ;; package CL; so maybe SB!VM:VM-BYTE?
506   (declare (type (simple-array (unsigned-byte 8) 1) bv))
507   (declare (type sap sap))
508   (declare (type fixnum offset))
509   ;; FIXME: Actually it looks as though this, and most other calls
510   ;; to COPY-TO-SYSTEM-AREA, could be written more concisely with BYTE-BLT.
511   ;; Except that the DST-END-DST-START convention for the length is confusing.
512   ;; Perhaps I could rename BYTE-BLT to BYTE-BLIT and replace the
513   ;; DST-END argument with an N-BYTES argument?
514   (copy-to-system-area bv
515                        (* sb!vm:vector-data-offset sb!vm:word-bits)
516                        sap
517                        offset
518                        (* (length bv) sb!vm:byte-bits)))