/[cmucl]/src/code/bit-bash.lisp
ViewVC logotype

Contents of /src/code/bit-bash.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.27 - (show annotations)
Mon Apr 19 02:18:03 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.26: +9 -9 lines
Remove _N"" reader macro from docstrings when possible.
1 ;;; -*- Log: code.log; Package: VM -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/bit-bash.lisp,v 1.27 2010/04/19 02:18:03 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Functions to implement bit bashing.
13 ;;;
14 ;;; Written by William Lott.
15 ;;;
16
17 (in-package "VM")
18
19 (intl:textdomain "cmucl")
20
21
22 ;;;; Constants and Types.
23
24
25 (eval-when (compile load eval)
26
27 (defconstant unit-bits vm:word-bits
28 "The number of bits to process at a time.")
29
30 (defconstant max-bits (1- (ash 1 vm:word-bits))
31 "The maximum number of bits that can be dealt with during a single call.")
32
33
34 (deftype unit ()
35 `(unsigned-byte ,unit-bits))
36
37 (deftype offset ()
38 `(integer 0 ,max-bits))
39
40 (deftype bit-offset ()
41 `(integer 0 (,unit-bits)))
42
43 (deftype bit-count ()
44 `(integer 1 (,unit-bits)))
45
46 (deftype word-offset ()
47 `(integer 0 (,(ceiling max-bits unit-bits))))
48
49
50 ); eval-when
51
52
53
54 ;;;; Support routines.
55
56 ;;; A particular implementation must offer either VOPs to translate these, or
57 ;;; deftransforms to convert them into something supported by the architecture.
58 ;;;
59 (macrolet ((frob (name &rest args)
60 `(defun ,name ,args
61 (,name ,@args))))
62 (frob 32bit-logical-not x)
63 (frob 32bit-logical-and x y)
64 (frob 32bit-logical-or x y)
65 (frob 32bit-logical-xor x y)
66 (frob 32bit-logical-nor x y)
67 (frob 32bit-logical-eqv x y)
68 (frob 32bit-logical-nand x y)
69 (frob 32bit-logical-andc1 x y)
70 (frob 32bit-logical-andc2 x y)
71 (frob 32bit-logical-orc1 x y)
72 (frob 32bit-logical-orc2 x y))
73
74
75 (eval-when (compile eval)
76 (defmacro byte-order-dispatch (big-endian little-endian)
77 (ecase (c:backend-byte-order c:*target-backend*)
78 (:big-endian big-endian)
79 (:little-endian little-endian))))
80
81 (defun shift-towards-start (number count)
82 "Shift NUMBER by COUNT bits, adding zero bits at the ``end'' and removing
83 bits from the ``start.'' On big-endian machines this is a left-shift and
84 on little-endian machines this is a right-shift. Note: only the low 5/6 bits
85 of count are significant."
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 (byte-order-dispatch
92 (ash (ldb (byte (- unit-bits count) 0) number) count)
93 (ash number (- count))))))
94
95 (defun shift-towards-end (number count)
96 "Shift NUMBER by COUNT bits, adding zero bits at the ``start'' and removing
97 bits from the ``end.'' On big-endian machines this is a right-shift and
98 on little-endian machines this is a left-shift."
99 (declare (type unit number) (fixnum count))
100 (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count)))
101 (declare (type bit-offset count))
102 (if (zerop count)
103 number
104 (byte-order-dispatch
105 (ash number (- count))
106 (ash (ldb (byte (- unit-bits count) 0) number) count)))))
107
108 (declaim (inline start-mask end-mask fix-sap-and-offset))
109 (defun start-mask (count)
110 "Produce a mask that contains 1's for the COUNT ``start'' bits and 0's for
111 the remaining ``end'' bits. Only the lower 5 bits of COUNT are significant."
112 (declare (fixnum count))
113 (shift-towards-start (1- (ash 1 unit-bits)) (- count)))
114
115 (defun end-mask (count)
116 "Produce a mask that contains 1's for the COUNT ``end'' bits and 0's for
117 the remaining ``start'' bits. Only the lower 5 bits of COUNT are
118 significant."
119 (declare (fixnum count))
120 (shift-towards-end (1- (ash 1 unit-bits)) (- count)))
121
122 (defun fix-sap-and-offset (sap offset)
123 "Align the SAP to a word boundry, and update the offset accordingly."
124 (declare (type system-area-pointer sap)
125 (type index offset)
126 (values system-area-pointer index))
127 (let ((address (sap-int sap)))
128 (values (int-sap #-(or alpha amd64) (32bit-logical-andc2 address 3)
129 #+alpha (ash (ash address -2) 2)
130 #+amd64 (ash (ash address -3) 3))
131 (+ (* (logand address #+amd64 7 #-amd64 3) byte-bits) offset))))
132
133 (declaim (inline word-sap-ref %set-word-sap-ref))
134 ;;;
135 (defun word-sap-ref (sap offset)
136 (declare (type system-area-pointer sap)
137 (type index offset)
138 (values (unsigned-byte #+amd64 64 #-amd64 32))
139 (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
140 #+amd64 (sap-ref-64 sap (the index (ash offset 3)))
141 #-amd64 (sap-ref-32 sap (the index (ash offset 2))))
142 ;;;
143 (defun %set-word-sap-ref (sap offset value)
144 (declare (type system-area-pointer sap)
145 (type index offset)
146 (type (unsigned-byte #+amd64 64 #-amd64 32) value)
147 (values (unsigned-byte #+amd64 64 #-amd64 32))
148 (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
149 (setf #+amd64 (sap-ref-64 sap (the index (ash offset 3)))
150 #-amd64 (sap-ref-32 sap (the index (ash offset 2))) value))
151 ;;;
152 (defsetf word-sap-ref %set-word-sap-ref)
153
154
155
156 ;;;; DO-CONSTANT-BIT-BASH
157
158 (declaim (inline do-constant-bit-bash))
159 (defun do-constant-bit-bash (dst dst-offset length value dst-ref-fn dst-set-fn)
160 "Fill DST with VALUE starting at DST-OFFSET and continuing for LENGTH bits."
161 (declare (type offset dst-offset) (type unit value)
162 (type function dst-ref-fn dst-set-fn))
163 (multiple-value-bind (dst-word-offset dst-bit-offset)
164 (floor dst-offset unit-bits)
165 (declare (type word-offset dst-word-offset)
166 (type bit-offset dst-bit-offset))
167 (multiple-value-bind (words final-bits)
168 (floor (+ dst-bit-offset length) unit-bits)
169 (declare (type word-offset words) (type bit-offset final-bits))
170 (if (zerop words)
171 (unless (zerop length)
172 (funcall dst-set-fn dst dst-word-offset
173 (if (= length unit-bits)
174 value
175 (let ((mask (shift-towards-end (start-mask length)
176 dst-bit-offset)))
177 (declare (type unit mask))
178 (32bit-logical-or
179 (32bit-logical-and value mask)
180 (32bit-logical-andc2
181 (funcall dst-ref-fn dst dst-word-offset)
182 mask))))))
183 (let ((interior (floor (- length final-bits) unit-bits)))
184 (unless (zerop dst-bit-offset)
185 (let ((mask (end-mask (- dst-bit-offset))))
186 (declare (type unit mask))
187 (funcall dst-set-fn dst dst-word-offset
188 (32bit-logical-or
189 (32bit-logical-and value mask)
190 (32bit-logical-andc2
191 (funcall dst-ref-fn dst dst-word-offset)
192 mask))))
193 (incf dst-word-offset))
194 (dotimes (i interior)
195 (funcall dst-set-fn dst dst-word-offset value)
196 (incf dst-word-offset))
197 (unless (zerop final-bits)
198 (let ((mask (start-mask final-bits)))
199 (declare (type unit mask))
200 (funcall dst-set-fn dst dst-word-offset
201 (32bit-logical-or
202 (32bit-logical-and value mask)
203 (32bit-logical-andc2
204 (funcall dst-ref-fn dst dst-word-offset)
205 mask)))))))))
206 (undefined-value))
207
208
209 ;;;; DO-UNARY-BIT-BASH
210
211 (declaim (inline do-unary-bit-bash))
212 (defun do-unary-bit-bash (src src-offset dst dst-offset length
213 dst-ref-fn dst-set-fn src-ref-fn)
214 (declare (type offset src-offset dst-offset length)
215 (type function dst-ref-fn dst-set-fn src-ref-fn))
216 (multiple-value-bind (dst-word-offset dst-bit-offset)
217 (floor dst-offset unit-bits)
218 (declare (type word-offset dst-word-offset)
219 (type bit-offset dst-bit-offset))
220 (multiple-value-bind (src-word-offset src-bit-offset)
221 (floor src-offset unit-bits)
222 (declare (type word-offset src-word-offset)
223 (type bit-offset src-bit-offset))
224 (cond
225 ((<= (+ dst-bit-offset length) unit-bits)
226 ;; We are only writing one word, so it doesn't matter what order
227 ;; we do it in. But we might be reading from multiple words, so take
228 ;; care.
229 (cond
230 ((zerop length)
231 ;; Actually, we aren't even writing one word. This is real easy.
232 )
233 ((= length unit-bits)
234 ;; dst-bit-offset must be equal to zero, or we would be writing
235 ;; multiple words. If src-bit-offset is also zero, then we
236 ;; just transfer the single word. Otherwise we have to extract bits
237 ;; from two src words.
238 (funcall dst-set-fn dst dst-word-offset
239 (if (zerop src-bit-offset)
240 (funcall src-ref-fn src src-word-offset)
241 (32bit-logical-or
242 (shift-towards-start
243 (funcall src-ref-fn src src-word-offset)
244 src-bit-offset)
245 (shift-towards-end
246 (funcall src-ref-fn src (1+ src-word-offset))
247 (- src-bit-offset))))))
248 (t
249 ;; We are only writing some portion of the dst word, so we need to
250 ;; preserve the extra bits. Also, we still don't know if we need
251 ;; one or two source words.
252 (let ((mask (shift-towards-end (start-mask length) dst-bit-offset))
253 (orig (funcall dst-ref-fn dst dst-word-offset))
254 (value
255 (if (> src-bit-offset dst-bit-offset)
256 ;; The source starts further into the word than does
257 ;; the dst, so the source could extend into the next
258 ;; word. If it does, we have to merge the two words,
259 ;; and if not, we can just shift the first word.
260 (let ((src-bit-shift (- src-bit-offset dst-bit-offset)))
261 (if (> (+ src-bit-offset length) unit-bits)
262 (32bit-logical-or
263 (shift-towards-start
264 (funcall src-ref-fn src src-word-offset)
265 src-bit-shift)
266 (shift-towards-end
267 (funcall src-ref-fn src (1+ src-word-offset))
268 (- src-bit-shift)))
269 (shift-towards-start
270 (funcall src-ref-fn src src-word-offset)
271 src-bit-shift)))
272 ;; The dst starts further into the word than does the
273 ;; source, so we know the source can't extend into
274 ;; a second word (or else the dst would too, and we
275 ;; wouldn't be in this branch).
276 (shift-towards-end
277 (funcall src-ref-fn src src-word-offset)
278 (- dst-bit-offset src-bit-offset)))))
279 (declare (type unit mask orig value))
280 ;; Replace the dst word.
281 (funcall dst-set-fn dst dst-word-offset
282 (32bit-logical-or
283 (32bit-logical-and value mask)
284 (32bit-logical-andc2 orig mask)))))))
285 ((= src-bit-offset dst-bit-offset)
286 ;; The source and dst are aligned, so we don't need to shift
287 ;; anything. But we have to pick the direction of the loop
288 ;; in case the source and dst are really the same thing.
289 (multiple-value-bind (words final-bits)
290 (floor (+ dst-bit-offset length) unit-bits)
291 (declare (type word-offset words) (type bit-offset final-bits))
292 (let ((interior (floor (- length final-bits) unit-bits)))
293 (declare (type word-offset interior))
294 (cond
295 ((<= dst-offset src-offset)
296 ;; We need to loop from left to right
297 (unless (zerop dst-bit-offset)
298 ;; We are only writing part of the first word, so mask off the
299 ;; bits we want to preserve.
300 (let ((mask (end-mask (- dst-bit-offset)))
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 (32bit-logical-and value mask)
306 (32bit-logical-andc2 orig mask))))
307 (incf src-word-offset)
308 (incf dst-word-offset))
309 ;; Just copy the interior words.
310 (dotimes (i interior)
311 (funcall dst-set-fn dst dst-word-offset
312 (funcall src-ref-fn src src-word-offset))
313 (incf src-word-offset)
314 (incf dst-word-offset))
315 (unless (zerop final-bits)
316 ;; We are only writing part of the last word.
317 (let ((mask (start-mask final-bits))
318 (orig (funcall dst-ref-fn dst dst-word-offset))
319 (value (funcall src-ref-fn src src-word-offset)))
320 (declare (type unit mask orig value))
321 (funcall dst-set-fn dst dst-word-offset
322 (32bit-logical-or
323 (32bit-logical-and value mask)
324 (32bit-logical-andc2 orig mask))))))
325 (t
326 ;; We need to loop from right to left.
327 (incf dst-word-offset words)
328 (incf src-word-offset words)
329 (unless (zerop final-bits)
330 (let ((mask (start-mask final-bits))
331 (orig (funcall dst-ref-fn dst dst-word-offset))
332 (value (funcall src-ref-fn src src-word-offset)))
333 (declare (type unit mask orig value))
334 (funcall dst-set-fn dst dst-word-offset
335 (32bit-logical-or
336 (32bit-logical-and value mask)
337 (32bit-logical-andc2 orig mask)))))
338 (dotimes (i interior)
339 (decf src-word-offset)
340 (decf dst-word-offset)
341 (funcall dst-set-fn dst dst-word-offset
342 (funcall src-ref-fn src src-word-offset)))
343 (unless (zerop dst-bit-offset)
344 (decf src-word-offset)
345 (decf dst-word-offset)
346 (let ((mask (end-mask (- dst-bit-offset)))
347 (orig (funcall dst-ref-fn dst dst-word-offset))
348 (value (funcall src-ref-fn src src-word-offset)))
349 (declare (type unit mask orig value))
350 (funcall dst-set-fn dst dst-word-offset
351 (32bit-logical-or
352 (32bit-logical-and value mask)
353 (32bit-logical-andc2 orig mask))))))))))
354 (t
355 ;; They aren't aligned.
356 (multiple-value-bind (words final-bits)
357 (floor (+ dst-bit-offset length) unit-bits)
358 (declare (type word-offset words) (type bit-offset final-bits))
359 (let ((src-shift (mod (- src-bit-offset dst-bit-offset) unit-bits))
360 (interior (floor (- length final-bits) unit-bits)))
361 (declare (type bit-offset src-shift)
362 (type word-offset interior))
363 (cond
364 ((<= dst-offset src-offset)
365 ;; We need to loop from left to right
366 (let ((prev 0)
367 (next (funcall src-ref-fn src src-word-offset)))
368 (declare (type unit prev next))
369 (flet ((get-next-src ()
370 (setf prev next)
371 (setf next (funcall src-ref-fn src
372 (incf src-word-offset)))))
373 (declare (inline get-next-src))
374 (unless (zerop dst-bit-offset)
375 (when (> src-bit-offset dst-bit-offset)
376 (get-next-src))
377 (let ((mask (end-mask (- dst-bit-offset)))
378 (orig (funcall dst-ref-fn dst dst-word-offset))
379 (value (32bit-logical-or
380 (shift-towards-start prev src-shift)
381 (shift-towards-end next (- src-shift)))))
382 (declare (type unit mask orig value))
383 (funcall dst-set-fn dst dst-word-offset
384 (32bit-logical-or
385 (32bit-logical-and value mask)
386 (32bit-logical-andc2 orig mask)))
387 (incf dst-word-offset)))
388 (dotimes (i interior)
389 (get-next-src)
390 (let ((value (32bit-logical-or
391 (shift-towards-end next (- src-shift))
392 (shift-towards-start prev src-shift))))
393 (declare (type unit value))
394 (funcall dst-set-fn dst dst-word-offset value)
395 (incf dst-word-offset)))
396 (unless (zerop final-bits)
397 (let ((value
398 (if (> (+ final-bits src-shift) unit-bits)
399 (progn
400 (get-next-src)
401 (32bit-logical-or
402 (shift-towards-end next (- src-shift))
403 (shift-towards-start prev src-shift)))
404 (shift-towards-start next src-shift)))
405 (mask (start-mask final-bits))
406 (orig (funcall dst-ref-fn dst dst-word-offset)))
407 (declare (type unit mask orig value))
408 (funcall dst-set-fn dst dst-word-offset
409 (32bit-logical-or
410 (32bit-logical-and value mask)
411 (32bit-logical-andc2 orig mask))))))))
412 (t
413 ;; We need to loop from right to left.
414 (incf dst-word-offset words)
415 (incf src-word-offset
416 (1- (ceiling (+ src-bit-offset length) unit-bits)))
417 (let ((next 0)
418 (prev (funcall src-ref-fn src src-word-offset)))
419 (declare (type unit prev next))
420 (flet ((get-next-src ()
421 (setf next prev)
422 (setf prev (funcall src-ref-fn src
423 (decf src-word-offset)))))
424 (declare (inline get-next-src))
425 (unless (zerop final-bits)
426 (when (> final-bits (- unit-bits src-shift))
427 (get-next-src))
428 (let ((value (32bit-logical-or
429 (shift-towards-end next (- src-shift))
430 (shift-towards-start prev src-shift)))
431 (mask (start-mask final-bits))
432 (orig (funcall dst-ref-fn dst dst-word-offset)))
433 (declare (type unit mask orig value))
434 (funcall dst-set-fn dst dst-word-offset
435 (32bit-logical-or
436 (32bit-logical-and value mask)
437 (32bit-logical-andc2 orig mask)))))
438 (decf dst-word-offset)
439 (dotimes (i interior)
440 (get-next-src)
441 (let ((value (32bit-logical-or
442 (shift-towards-end next (- src-shift))
443 (shift-towards-start prev src-shift))))
444 (declare (type unit value))
445 (funcall dst-set-fn dst dst-word-offset value)
446 (decf dst-word-offset)))
447 (unless (zerop dst-bit-offset)
448 (if (> src-bit-offset dst-bit-offset)
449 (get-next-src)
450 (setf next prev prev 0))
451 (let ((mask (end-mask (- dst-bit-offset)))
452 (orig (funcall dst-ref-fn dst dst-word-offset))
453 (value (32bit-logical-or
454 (shift-towards-start prev src-shift)
455 (shift-towards-end next (- src-shift)))))
456 (declare (type unit mask orig value))
457 (funcall dst-set-fn dst dst-word-offset
458 (32bit-logical-or
459 (32bit-logical-and value mask)
460 (32bit-logical-andc2 orig mask)))))))))))))))
461 (undefined-value))
462
463
464 ;;;; The actual bashers.
465
466 (defun bit-bash-fill (value dst dst-offset length)
467 (declare (type unit value) (type offset dst-offset length))
468 (locally
469 (declare (optimize (speed 3) (safety 0)))
470 (do-constant-bit-bash dst dst-offset length value
471 #'%raw-bits #'%set-raw-bits)))
472
473 (defun system-area-fill (value dst dst-offset length)
474 (declare (type unit value) (type offset dst-offset length))
475 (locally
476 (declare (optimize (speed 3) (safety 0)))
477 (multiple-value-bind (dst dst-offset)
478 (fix-sap-and-offset dst dst-offset)
479 (do-constant-bit-bash dst dst-offset length value
480 #'word-sap-ref #'%set-word-sap-ref))))
481
482 (defun bit-bash-copy (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 (inline do-unary-bit-bash))
487 (do-unary-bit-bash src src-offset dst dst-offset length
488 #'%raw-bits #'%set-raw-bits #'%raw-bits)))
489
490 (defun system-area-copy (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)
495 (fix-sap-and-offset src src-offset)
496 (declare (type system-area-pointer src))
497 (multiple-value-bind (dst dst-offset)
498 (fix-sap-and-offset dst dst-offset)
499 (declare (type system-area-pointer dst))
500 (do-unary-bit-bash src src-offset dst dst-offset length
501 #'word-sap-ref #'%set-word-sap-ref
502 #'word-sap-ref)))))
503
504 (defun copy-to-system-area (src src-offset dst dst-offset length)
505 (declare (type offset src-offset dst-offset length))
506 (locally
507 (declare (optimize (speed 3) (safety 0)))
508 (multiple-value-bind (dst dst-offset)
509 (fix-sap-and-offset dst dst-offset)
510 (do-unary-bit-bash src src-offset dst dst-offset length
511 #'word-sap-ref #'%set-word-sap-ref #'%raw-bits))))
512
513 (defun copy-from-system-area (src src-offset dst dst-offset length)
514 (declare (type offset src-offset dst-offset length))
515 (locally
516 (declare (optimize (speed 3) (safety 0)))
517 (multiple-value-bind (src src-offset)
518 (fix-sap-and-offset src src-offset)
519 (do-unary-bit-bash src src-offset dst dst-offset length
520 #'%raw-bits #'%set-raw-bits #'word-sap-ref))))
521

  ViewVC Help
Powered by ViewVC 1.1.5