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.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/bit-bash.lisp,v 1.16 1992/07/31 17:50:18 wlott Exp $")
;;; **********************************************************************
;;;
;;; Functions to implement bit bashing.
;;;
;;; Written by William Lott.
;;;
;;;; Constants and Types.
(eval-when (compile load eval)
(defconstant unit-bits vm:word-bits
"The number of bits to process at a time.")
(defconstant max-bits (ash most-positive-fixnum -2)
"The maximum number of bits that can be delt with during a single call.")
(deftype unit ()
`(unsigned-byte ,unit-bits))
(deftype offset ()
`(integer 0 ,max-bits))
(deftype bit-offset ()
`(integer 0 (,unit-bits)))
(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))
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
(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 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)))))
(proclaim '(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 (32bit-logical-andc2 address 3))
(+ (* (logand address 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)
(values (unsigned-byte 32))
(optimize (speed 3) (safety 0) (inhibit-warnings 3)))
(sap-ref-32 sap (the index (ash offset 2))))
;;;
(declare (type system-area-pointer sap)
(type index offset)
(type (unsigned-byte 32) value)
(values (unsigned-byte 32))
(optimize (speed 3) (safety 0) (inhibit-warnings 3)))
(setf (sap-ref-32 sap (the index (ash offset 2))) value))
;;;
(defsetf word-sap-ref %set-word-sap-ref)
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
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
;;;; DO-CONSTANT-BIT-BASH
(proclaim '(inline 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."
(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))
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
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
279
280
281
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
361
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
;;;; DO-UNARY-BIT-BASH
(proclaim '(inline 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 arn't even writing one word. This is real easy.
)
((= 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 not 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)
(- 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
;; They arn't aligned.
(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))
424
425
426
427
428
429
430
431
432
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
(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))
;;;; 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 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))))