source: project/release/3/mathh/trunk/bitwise-extras.scm @ 8594

Last change on this file since 8594 was 8594, checked in by Kon Lovett, 12 years ago

Save.

File size: 15.9 KB
Line 
1;;;; bitwise-extras.scm
2;;;; Kon Lovett, Feb '08
3
4(declare
5        (usual-integrations)
6        (generic)
7  (disable-interrupts)
8        (no-bound-checks)
9        (no-procedure-checks-for-usual-bindings)
10  (export
11    boolean->bit
12    ; Checked
13    pow2log2
14    bitwise-if
15    bitwise-if-not
16    bitwise-test?
17    bitwise-bit-count
18    bitwise-length
19    bitwise-first-bit-set
20    bitwise-last-bit-set
21    bitwise-bit-set?
22    bitwise-copy-bit
23    bitwise-bit-field
24    bitwise-copy-bit-field
25    bitwise-rotate-bit-field
26    bitwise-reverse
27    bitwise-reverse-bit-field
28    bitwise-list->integer
29    bitwise-integer->list
30    bitwise-arithmetic-shift
31    bitwise-arithmetic-shift-left
32    bitwise-arithmetic-shift-right
33    ; Unchecked
34    %pow2log2
35    %bitwise-if
36    %bitwise-if-not
37    %bitwise-test?
38    %bitwise-bit-count
39    %bitwise-length
40    %bitwise-first-bit-set
41    %bitwise-last-bit-set
42    %bitwise-bit-set?
43    %bitwise-copy-bit
44    %bitwise-bit-field
45    %bitwise-copy-bit-field
46    %bitwise-rotate-bit-field
47    %bitwise-reverse
48    %bitwise-reverse-bit-field
49    %bitwise-list->integer
50    %bitwise-integer->list ) )
51
52(use srfi-1)
53(use mathh-int)
54
55#>
56/* Bit operations */
57
58#define HIGH_MASK( s )                (-1 << (s))
59#define LOW_MASK( s )                 (~ HIGH_MASK( s ))
60
61#define HIGH_BITS( n, s )             ((n) & HIGH_MASK( s ))
62#define LOW_BITS( n, s )              ((n) & LOW_MASK( s ))
63
64#define BITS( n, s, e )               (((n) & LOW_MASK( e )) >> (s))
65#define ISOLATE_BITS( n, s, e )       (BITS( (n), (s), (e) ) << (s))
66
67#define BITS_MERGE( mask, a, b )      (((a) & (mask)) ^ ((b) & ~(mask)))
68#define BITS_MERGE_NOT( mask, a, b )  ((a) ^ (((a) ^ (b)) & (mask)))
69
70#define BITS_TEST( a, b )             (((a) & (b)) != 0)
71
72#define BITS_COPY( t, s, e, f ) \
73    (BITS_MERGE( HIGH_MASK( s ) & LOW_MASK( e ), (f) << (s), (t)))
74
75#define BIT_SET( n, s )               ((n) | (1 << (s)))
76#define BIT_CLEAR( n, s )             ((n) & ~ (1 << (s)))
77#define BIT_TEST( n, s )              ((n) & (1 << (s)))
78#define BIT_COPY( n, s, b )           BITS_MERGE( 1 << (s), (b) << (s), (n) )
79
80/* Integer log2 - high bit set */
81static C_uword
82C_uword_log2( C_uword n)
83{
84    static const C_uword
85    LogTable256[] = { /* 16 x 16 */
86      0, 0, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3,
87      4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
88      5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
89      5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
90      6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
91      6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
92      6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
93      6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
94      7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
95      7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
96      7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
97      7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
98      7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
99      7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
100      7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
101      7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7};
102
103    C_uword r;
104
105    if (0 == n) return 0;
106
107#   ifdef C_SIXTY_FOUR
108    C_uword ttt;
109    if ((ttt = n >> 32)) {
110        C_uword tt;
111        if ((tt = ttt >> 16)) {
112            C_uword t;
113            r = (t = tt >> 8) ? 48 + LogTable256[ t ] : 40 + LogTable256[ tt ];
114        } else {
115            C_uword t;
116            r = (t = n >> 8) ? 32 + LogTable256[ t ] : 16 + LogTable256[ n ];
117        }
118    } else if ((ttt = ttt >> 16)) {
119        C_uword t;
120        r = (t = ttt >> 8) ? 24 + LogTable256[ t ] : 16 + LogTable256[ ttt ];
121    } else {
122        C_uword t;
123        r = (t = ttt >> 8) ? 8 + LogTable256[ t ] : LogTable256[ n ];
124    }
125#   else
126    C_uword tt;
127    if ((tt = n >> 16)) {
128        C_uword t;
129        r = (t = tt >> 8) ? 24 + LogTable256[ t ] : 16 + LogTable256[ tt ];
130    } else {
131        C_uword t;
132        r = (t = n >> 8) ? 8 + LogTable256[ t ] : LogTable256[ n ];
133    }
134#   endif
135
136    return r + 1;
137}
138
139/* - low bit set */
140#define C_UWORD_LOG2_FACTORS( n )   (C_uword_log2( (n) & - (n) ) - 1)
141
142/* Number of 1 bits */
143static
144C_uword C_uword_bits( C_uword n )
145{
146#       define TWO( c )       (0x1u << (c))
147#       define MASK( c )      (((C_uword) (-1)) / (TWO( TWO( c ) ) + 1u))
148#       define COUNT( x, c )  ((x) & MASK( c )) + (((x) >> (TWO( c ))) & MASK( c ))
149
150        n = COUNT( n, 0 );
151        n = COUNT( n, 1 );
152        n = COUNT( n, 2 );
153        n = COUNT( n, 3 );
154        n = COUNT( n, 4 );
155#       ifdef C_SIXTY_FOUR
156        n = COUNT( n, 5 );
157#       endif
158
159        return n;
160
161# undef COUNT
162# undef MASK
163# undef TWO
164}
165
166static const unsigned char
167BitReverseTable256[] = {
168  0x00, 0x80, 0x40, 0xC0, 0x20, 0xA0, 0x60, 0xE0, 0x10, 0x90, 0x50, 0xD0, 0x30, 0xB0, 0x70, 0xF0,
169  0x08, 0x88, 0x48, 0xC8, 0x28, 0xA8, 0x68, 0xE8, 0x18, 0x98, 0x58, 0xD8, 0x38, 0xB8, 0x78, 0xF8,
170  0x04, 0x84, 0x44, 0xC4, 0x24, 0xA4, 0x64, 0xE4, 0x14, 0x94, 0x54, 0xD4, 0x34, 0xB4, 0x74, 0xF4,
171  0x0C, 0x8C, 0x4C, 0xCC, 0x2C, 0xAC, 0x6C, 0xEC, 0x1C, 0x9C, 0x5C, 0xDC, 0x3C, 0xBC, 0x7C, 0xFC,
172  0x02, 0x82, 0x42, 0xC2, 0x22, 0xA2, 0x62, 0xE2, 0x12, 0x92, 0x52, 0xD2, 0x32, 0xB2, 0x72, 0xF2,
173  0x0A, 0x8A, 0x4A, 0xCA, 0x2A, 0xAA, 0x6A, 0xEA, 0x1A, 0x9A, 0x5A, 0xDA, 0x3A, 0xBA, 0x7A, 0xFA,
174  0x06, 0x86, 0x46, 0xC6, 0x26, 0xA6, 0x66, 0xE6, 0x16, 0x96, 0x56, 0xD6, 0x36, 0xB6, 0x76, 0xF6,
175  0x0E, 0x8E, 0x4E, 0xCE, 0x2E, 0xAE, 0x6E, 0xEE, 0x1E, 0x9E, 0x5E, 0xDE, 0x3E, 0xBE, 0x7E, 0xFE,
176  0x01, 0x81, 0x41, 0xC1, 0x21, 0xA1, 0x61, 0xE1, 0x11, 0x91, 0x51, 0xD1, 0x31, 0xB1, 0x71, 0xF1,
177  0x09, 0x89, 0x49, 0xC9, 0x29, 0xA9, 0x69, 0xE9, 0x19, 0x99, 0x59, 0xD9, 0x39, 0xB9, 0x79, 0xF9,
178  0x05, 0x85, 0x45, 0xC5, 0x25, 0xA5, 0x65, 0xE5, 0x15, 0x95, 0x55, 0xD5, 0x35, 0xB5, 0x75, 0xF5,
179  0x0D, 0x8D, 0x4D, 0xCD, 0x2D, 0xAD, 0x6D, 0xED, 0x1D, 0x9D, 0x5D, 0xDD, 0x3D, 0xBD, 0x7D, 0xFD,
180  0x03, 0x83, 0x43, 0xC3, 0x23, 0xA3, 0x63, 0xE3, 0x13, 0x93, 0x53, 0xD3, 0x33, 0xB3, 0x73, 0xF3,
181  0x0B, 0x8B, 0x4B, 0xCB, 0x2B, 0xAB, 0x6B, 0xEB, 0x1B, 0x9B, 0x5B, 0xDB, 0x3B, 0xBB, 0x7B, 0xFB,
182  0x07, 0x87, 0x47, 0xC7, 0x27, 0xA7, 0x67, 0xE7, 0x17, 0x97, 0x57, 0xD7, 0x37, 0xB7, 0x77, 0xF7,
183  0x0F, 0x8F, 0x4F, 0xCF, 0x2F, 0xAF, 0x6F, 0xEF, 0x1F, 0x9F, 0x5F, 0xDF, 0x3F, 0xBF, 0x7F, 0xFF};
184
185#define REVERSE_BYTE( b )   BitReverseTable256[ (b) ]
186
187#define REVERSE_LOW_BITS( b, w ) \
188    ((CHAR_BIT == (w)) \
189        ? REVERSE_BYTE( b ) \
190        : (HIGH_BITS( REVERSE_BYTE( LOW_BITS( (b), (w) ) ), (w) ) >> (w)))
191
192#define REVERSE_BITS( b, s, e ) \
193    ((0 == (s)) \
194        ? REVERSE_LOW_BITS( (b), (e) ) \
195        : (REVERSE_LOW_BITS( ((b) >> (e)), ((e) - (s)) ) << (e)))
196
197#ifdef C_BIG_ENDIAN
198#else
199#endif
200
201#ifdef C_SIXTY_FOUR
202#else
203#endif
204
205#if 0
206static C_uword
207C_uword_bits_reverse( C_uword n, C_uword s, C_uword e)
208{
209#   define FULBYT( n )   ((n) / CHAR_BIT)
210#   define REMBYT( n )   (0 == ((n) % CHAR_BIT) ? 0 : 1)
211#   define TOTBYT( n )   (FULBYT( n ) + REMBYT( n ))
212
213    C_uword wid = e - s;
214
215    C_uword SS = s % CHAR_BIT;
216    C_uword EE = e % CHAR_BIT;
217    C_word FUL = (C_word) wid - (SS * CHAR_BIT) - (EE * CHAR_BIT);
218
219    C_uword SE = MIN( CHAR_BIT, EE );
220    C_uword ES = MAX( 0, FUL );
221
222  #ifdef C_BIG_ENDIAN
223    uint8_t *srt = ((uint8_t *) &n) + (sizeof( C_uword ) - FULBYT( e ));
224    uint8_t *end = ((uint8_t *) &n) + (sizeof( C_uword ) - FULBYT( s ));
225  #else
226    uint8_t *srt = ((uint8_t *) &n) + FULBYT( s );
227    uint8_t *end = ((uint8_t *) &n) + FULBYT( e );
228  #endif
229
230    for ( ; end > srt; ++srt, --end) {
231      C_uword tmp = REVERSE_BYTE( *srt );
232      *srt = REVERSE_BYTE( *end );
233      *end = temp;
234    }
235
236    *srt = REVERSE_BITS( *srt, s % CHAR_BIT, e % CHAR_BIT );
237    *end = REVERSE_BITS( *end, s % CHAR_BIT, e % CHAR_BIT );
238}
239#endif
240<#
241
242;;;
243
244(define-inline (check-list loc obj)
245  (##sys#check-list obj loc) )
246
247(define-inline (check-integer loc obj)
248  (##sys#check-integer obj loc) )
249
250(define-inline (check-non-negative-integer loc obj)
251  (check-integer loc obj)
252  (when (negative? obj)
253    (##sys#signal-hook #:type-error loc
254     "bad argument type - not a non-negative integer" obj) ) )
255
256(define-inline (check-<= loc num1 num2)
257  (when (< num2 num1)
258    (##sys#signal-hook #:type-error loc
259     "bad argument type - not a valid interval" num1 num2) ) )
260
261;;;
262
263(define-inline (%boolean->bit b)
264  (if b #b1 #b0) )
265
266;;;
267
268(define %pow2log2
269  (foreign-lambda* unsigned-int ((integer value))
270   "return (2 << C_uword_log2( (C_uword) value ));"))
271
272(define %bitwise-if
273  (foreign-lambda* unsigned-int ((integer mask) (integer t) (integer f))
274   "return (BITS_MERGE( mask, t, f ));"))
275
276(define %bitwise-if-not
277  (foreign-lambda* unsigned-int ((integer mask) (integer t) (integer f))
278   "return (BITS_MERGE_NOT( mask, t, f ));"))
279
280(define %bitwise-test?
281  (foreign-lambda* bool ((integer a) (integer b))
282   "return (BITS_TEST( a, b ));"))
283
284(define %bitwise-bit-count
285  (foreign-lambda* unsigned-int ((integer value))
286   "return ((0 < value)\n"
287   "            ? C_uword_bits( (C_uword) value )\n"
288   "            : ((0 == value) ? 0 : /*~*/ C_uword_bits( (C_uword) (~ value) )));"))
289
290(define %bitwise-length
291  (foreign-lambda* unsigned-int ((integer value))
292   "return (C_uword_log2( (C_uword) ((value < 0) ? ~ value : value ) ));"))
293
294(define %bitwise-first-bit-set
295  (foreign-lambda* int ((integer value))
296   "return (C_UWORD_LOG2_FACTORS( (C_uword) value ));"))
297
298(define %bitwise-last-bit-set
299  (foreign-lambda* unsigned-int ((integer value))
300   "return (C_uword_log2( (C_uword) value ));"))
301
302(define %bitwise-bit-set?
303  (foreign-lambda* bool ((integer value) (unsigned-int index))
304   "return (BIT_TEST( value, index ));"))
305
306(define %bitwise-copy-bit
307  (foreign-lambda* integer ((integer to) (unsigned-int index) (unsigned-int bit))
308   "return (BIT_COPY( to, index, bit ));"))
309
310(define %bitwise-bit-field
311  (foreign-lambda* integer ((integer value) (unsigned-int start) (unsigned-int end))
312   "return (BITS( value, start, end ));"))
313
314(define %bitwise-copy-bit-field
315  (foreign-lambda* integer ((integer to) (unsigned-int start) (unsigned-int end) (integer from))
316   "return (BITS_COPY( to, start, end, from ));"))
317
318#; ; Doesn't work
319(define %bitwise-rotate-bit-field
320  (foreign-lambda* integer ((integer value) (unsigned-int start) (unsigned-int end) (unsigned-int count))
321    "#define ASH( n, s )  (0 < (s) ? (n) << (s) : (n) >> -(s))\n"
322    "C_uword wid = end - start;\n"
323    "C_word cnt = count % wid;\n"
324    "C_uword msk = LOW_MASK( wid );\n"
325    "C_uword fld = BITS( value, start, end );\n"
326    "return (((((msk & ASH( fld, cnt )) | ASH( fld, cnt - wid ))) << start)\n"
327    "        | (value & ~ (msk << start)));\n"
328    "#undef ASH"))
329
330(define %bitwise-rotate-bit-field
331  (foreign-lambda* integer ((integer value) (unsigned-int start) (unsigned-int end) (unsigned-int count))
332   #; ; Puts a penalty on the usual case
333   "if (0 == value) return (value);\n"
334   "C_uword wid = end - start;\n"
335   "C_uword cnt = count % wid;\n"
336   "C_uword fld = BITS( value, start, end );\n"
337   "return (BITS_COPY( value, start, end, ((fld << cnt) ^ (fld >> (wid - cnt))) ));"))
338
339#; ; TBD
340(define %bitwise-reverse-bit-field
341  (foreign-lambda* integer ((integer value) (unsigned-int start) (unsigned-int end))
342   "return (C_uword_bits_reverse( value, start, end ));"))
343
344(define (%bitwise-reverse value count)
345  (let ([negval? (negative? value)])
346    (do ([mask (if negval? (bitwise-not value) value) (arithmetic-shift mask -1)]
347         [count (- count 1) (- count 1)]
348         [revval 0 (bitwise-ior (arithmetic-shift revval 1) (bitwise-and 1 mask))])
349        ((negative? count) (if negval? (bitwise-not revval) revval)) ) ) )
350
351(define (%bitwise-reverse-bit-field value start end)
352  (let* ([width (- end start)]
353         [mask (bitwise-not (arithmetic-shift -1 width))]
354         [field (bitwise-and mask (arithmetic-shift value (- start)))])
355    (bitwise-ior (arithmetic-shift (%bitwise-reverse field width) start)
356                 (bitwise-and (bitwise-not (arithmetic-shift mask start)) value)) ) )
357
358(define (%bitwise-list->integer lst)
359  ; (list lsb .. msb)
360  (let loop ([l lst] [i 0] [n 0])
361    (if (null? l)
362        n
363        (loop (cdr l) (fx+ i 1) (%bitwise-copy-bit n i (%boolean->bit (car l)))) ) ) )
364
365(define %bitwise-integer->list
366  (let ([zero-list (make-list machine-word-bits #f)])
367    (lambda (value #!optional bitlen)
368      ; (list lsb .. msb)
369      (if (zero? value)
370          (if bitlen
371              (take zero-list bitlen)
372              zero-list )
373          (let ([bitlen (or bitlen (%bitwise-length value))])
374            (let loop ([i 0] [l '()])
375              (if (fx= bitlen i)
376                  l
377                  (loop (fx+ i 1) (cons (%bitwise-bit-set? value i) l)) ) ) ) ) ) ) )
378
379;;;
380
381(define (boolean->bit bit)
382  (if (and (integer? bit) (zero? bit))
383      0
384      (%boolean->bit bit)) )
385
386;;;
387
388(define (pow2log2 value)
389  (check-integer 'pow2log2 value)
390  (%pow2log2 value) )
391
392(define (bitwise-if mask true false)
393  (check-integer 'bitwise-if mask)
394  (check-integer 'bitwise-if true)
395  (check-integer 'bitwise-if false)
396  (%bitwise-if mask true false))
397
398(define (bitwise-if-not mask true false)
399  (check-integer 'bitwise-if-not mask)
400  (check-integer 'bitwise-if-not true)
401  (check-integer 'bitwise-if-not false)
402  (%bitwise-if-not mask true false))
403
404(define (bitwise-test? a b)
405  (check-integer 'bitwise-test? a)
406  (check-integer 'bitwise-test? b)
407  (%bitwise-test? a b))
408
409(define (bitwise-bit-count value)
410  (check-integer 'bitwise-bit-count value)
411  (%bitwise-bit-count value))
412
413(define (bitwise-length value)
414  (check-integer 'bitwise-length value)
415  (%bitwise-length value))
416
417(define (bitwise-first-bit-set value)
418  (check-integer 'bitwise-first-bit-set value)
419  (%bitwise-first-bit-set value))
420
421(define (bitwise-last-bit-set value)
422  (check-integer 'bitwise-last-bit-set value)
423  (%bitwise-last-bit-set value))
424
425(define (bitwise-bit-set? value index)
426  (check-integer 'bitwise-bit-set? value)
427  (check-non-negative-integer 'bitwise-bit-set? index)
428  (%bitwise-bit-set? value index))
429
430(define (bitwise-copy-bit to index bit)
431  (check-integer 'bitwise-copy-bit to)
432  (check-non-negative-integer 'bitwise-copy-bit index)
433  (%bitwise-copy-bit to index (boolean->bit bit)) )
434
435(define (bitwise-bit-field value start end)
436  (check-integer 'bitwise-bit-field value)
437  (check-non-negative-integer 'bitwise-bit-field start)
438  (check-non-negative-integer 'bitwise-bit-field end)
439  (check-<= 'bitwise-bit-field start end)
440  (%bitwise-bit-field value start end))
441
442(define (bitwise-copy-bit-field to start end from)
443  (check-integer 'bitwise-copy-bit-field to)
444  (check-non-negative-integer 'bitwise-copy-bit-field start)
445  (check-non-negative-integer 'bitwise-copy-bit-field end)
446  (check-<= 'bitwise-copy-bit-field start end)
447  (check-integer 'bitwise-copy-bit-field from)
448  (%bitwise-copy-bit-field to start end from))
449
450(define (bitwise-rotate-bit-field value start end count)
451  (check-integer 'bitwise-rotate-bit-field value)
452  (check-non-negative-integer 'bitwise-rotate-bit-field start)
453  (check-non-negative-integer 'bitwise-rotate-bit-field end)
454  (check-<= 'bitwise-rotate-bit-field start end)
455  (check-integer 'bitwise-rotate-bit-field count)
456  (%bitwise-rotate-bit-field value start end count) )
457
458(define (bitwise-reverse value count)
459  (check-integer 'bitwise-reverse value)
460  (check-non-negative-integer 'bitwise-reverse count)
461  (%bitwise-reverse value count) )
462
463(define (bitwise-reverse-bit-field value start end)
464  (check-integer 'bitwise-reverse-bit-field value)
465  (check-non-negative-integer 'bitwise-reverse-bit-field start)
466  (check-non-negative-integer 'bitwise-reverse-bit-field end)
467  (check-<= 'bitwise-reverse-bit-field start end)
468  (%bitwise-reverse-bit-field value start end) )
469
470(define (bitwise-list->integer lst)
471  (check-list 'bitwise-list->integer lst)
472  (%bitwise-list->integer lst) )
473
474(define (bitwise-integer->list value #!optional bitlen)
475  (check-integer 'bitwise-integer->list value)
476  (when bitlen (check-non-negative-integer 'bitwise-integer->list bitlen))
477  (%bitwise-integer->list value bitlen) )
478
479;;;
480
481(define bitwise-arithmetic-shift arithmetic-shift)
482
483(define (bitwise-arithmetic-shift-left value amount)
484  (check-non-negative-integer 'bitwise-arithmetic-shift-left amount)
485  (arithmetic-shift value amount) )
486
487(define (bitwise-arithmetic-shift-right value amount)
488  (check-non-negative-integer 'bitwise-arithmetic-shift-right amount)
489  (arithmetic-shift value (- amount)) )
Note: See TracBrowser for help on using the repository browser.