log2.pl
1 #! /export/home/a273121/perl-5.10.0-RC2/perl -l
2 # http://use.perl.org/comments.pl?sid=40855&cid=64834
3
4 require 5.010;
5 use Benchmark qw( :all);
6
7 our $quiet = 0;
8
9 for (@ARGV) {
10 test_it(*log2_xx) if /xx/i;
11 test_it(*log2_2) if /2/i;
12 test_it(*log2_3) if /3/i;
13 test_it(*log2_1) if /1/i;
14 test_it(*log2_Lc) if /const/i;
15
16 test_it(*floor_log2) if /swar/i;
17 test_it(*floor_log2_pt) if /pt/i;
18
19 print log(2) if /CC/i;
20
21 # cmpthese can be used both ways as well
22 $quiet = 1 and cmpthese(
23 $count,
24 {
25 map { ( $_ => "test_it(\*$_) for 1..10" ) }
26 qw/log2_LL log2_xx log2_2 log2_1 log2_3 log2_0 floor_log2 floor_log2_pt/
27 }
28 ) if /bench/i;
29 $quiet = 1 and cmpthese(
30 $count,
31 {
32 map { ( $_ => "test_it(\*$_) for 1..10" ) }
33 qw/log2_LL log2_Lc log2_Lcs /
34 }
35 ) if /LL/i;
36
37 }
38
39 sub log2_0 {
40 my $n = shift;
41
42 # print "n=$n";
43 die "log2 is only defined on positive numbers, n $n not" if $n <= 0;
44 my $str = unpack( "B12", pack( "F>", $n ) );
45 $str =~ s/^[01]/00000/; # drop sign and pad
46 my $exp = unpack( "s>", pack( "B*", $str ) );
47 return -1023 + $exp;
48 }
49
50 sub log2_1 {
51 my $n = shift;
52
53 # print "n=$n";
54 die "log2 is only defined on positive numbers" if $n <= 0;
55 my $str = unpack( "B28", pack( "F>", $n ) );
56 $str =~ s/^[01]/00000/; # drop sign and pad
57 my ( $exp, $mant ) = unpack( "S>*", pack( "B*", $str ) );
58
59 # print "exp= $exp mant=$mant";
60 # printf "mant=%x \n",$mant;
61
62 return -1023 # offset
63 + $exp + (
64 $mant >= 0xffff
65 ? 1.00 # synonym !
66 : $mant >= 0x6a09 ? 0.50
67 : 0
68 );
69 }
70
71 sub log2_2 {
72 my $n = shift;
73
74 # print "n=$n";
75 die "log2 is only defined on positive numbers" if $n <= 0;
76 my $str = unpack( "B28", pack( "F>", $n ) );
77 $str =~ s/^[01]/00000/; # drop sign and pad
78 my ( $exp, $mant ) = unpack( "S>*", pack( "B*", $str ) );
79
80 # print "exp= $exp mant=$mant";
81 printf "[EXP=%d 2^%d * 1x%04x]", $exp, $exp - 1023, $mant
82 unless $quiet;
83
84 return -1023 # offset
85 + $exp + (
86 $mant >= 0xffff
87 ? 1.00 # synonym !
88 : $mant >= 0xae89 ? 0.75
89 : $mant >= 0x6a09 ? 0.50
90 : $mant >= 0x306f ? 0.25
91 : 0
92 );
93 }
94
95 sub log2_3 {
96 my $n = shift;
97
98 # print "n=$n";
99 die "log2 is only defined on positive numbers" if $n <= 0;
100 my $str = unpack( "B28", pack( "F>", $n ) );
101 $str =~ s/^[01]/00000/; # drop sign and pad
102 my ( $exp, $mant ) = unpack( "S>*", pack( "B*", $str ) );
103
104 # print "exp= $exp mant=$mant";
105 printf "[EXP=%d 2^%d * 1x%04x]", $exp, $exp - 1023, $mant
106 unless $quiet;
107
108 my $ee = -1023 # offset
109 + $exp;
110
111 return $ee + (
112 $mant >= 0xffff
113 ? 1.000 # synonym !
114 : $mant >= 0xd581 ? 0.875
115 : $mant >= 0xae89 ? 0.750
116 : $mant >= 0x8ace ? 0.625
117 : $mant >= 0x6a09 ? 0.500
118 : $mant >= 0x4bfd ? 0.375
119 : $mant >= 0x306f ? 0.250
120 : $mant >= 0x172b ? 0.125
121 : 0.000
122 ) if $ee >= 0;
123
124 # fractions ...
125 return $ee + (
126 $mant >= 0xffff
127 ? 1.000 # synonym !
128 : $mant <= 0x0fff ? 0.000
129 : $mant <= 0x172b ? 0.125
130 : $mant <= 0x306f ? 0.250
131 : $mant <= 0x4bfd ? 0.375
132 : $mant <= 0x6a09 ? 0.500
133 : $mant <= 0x8ace ? 0.625
134 : $mant <= 0xae89 ? 0.750
135 : $mant <= 0xd581 ? 0.875
136 : 0.999
137 )
138
139 # 3rd frac bit but that doubles tests again ...
140 # this gives trunc @ 2bits not rounding,
141 # but that allows caller to
142 # round or trunc to ints.
143 }
144
145 our @Table;
146
147 INIT {
148 @Table = map {
149 log2_LL(
150 unpack(
151 "F>",
152 pack( "H16",
153 '3ff' . unpack( 'H2', pack( 's', $_ ) ) . ( '0' x 13 ) )
154 )
155 )
156 } 0 .. 255;
157 }
158
159 sub log2_xx {
160 my $n = shift;
161
162 # print "n=$n";
163 die "log2 is only defined on positive numbers" if $n <= 0;
164 my $str = unpack( "B28", pack( "F>", $n ) );
165 $str =~ s/^[01]/00000/; # drop sign and pad
166 my ( $exp, $mant ) = unpack( "S>*", pack( "B*", $str ) );
167
168 # print "exp= $exp mant=$mant";
169 printf "[EXP=%d 2^%d * 1x%04x]", $exp, $exp - 1023, $mant
170 unless $quiet;
171
172 my $ee = -1023 # offset
173 + $exp;
174 my $frac = $Table[ $mant >> 8 ];
175 printf "[%2x: %g]", $mant >> 8, $frac
176 unless $quiet;
177
178 return $ee + $frac;
179
180 }
181
182 # from http://aggregate.ee.engr.uky.edu/MAGIC/#Log2%20of%20an%20Integer C code
183 sub floor_log2 #(register unsigned int x)
184 {
185 my $x = shift;
186 $x |= ( $x >> 1 );
187 $x |= ( $x >> 2 );
188 $x |= ( $x >> 4 );
189 $x |= ( $x >> 8 );
190 $x |= ( $x >> 16 );
191
192 #ifdef LOG0UNDEFINED
193 return ( ones32($x) - 1 );
194
195 #else
196 # return(ones32($x >> 1));
197 #endif
198 }
199
200 # Population Count (Ones Count)
201
202 # http://aggregate.ee.engr.uky.edu/MAGIC/#Next%20Largest%20Power%20of%202
203 # The population count of a binary integer value x is the number
204 # of one bits in the value. Although many machines have single
205 # instructions for this, the single instructions are usually
206 # microcoded loops that test a bit per cycle; a log-time
207 # algorithm coded in C is often faster. The following code uses a
208 # variable-precision SWAR algorithm to perform a tree reduction
209 # adding the bits in a 32-bit value:
210 #
211
212 # unsigned int
213 sub ones32 #(register unsigned int x)
214 {
215
216 # 32-bit recursive reduction using SWAR...
217 # but first step is mapping 2-bit values
218 # into sum of 2 1-bit values in sneaky way
219
220 my $x = shift;
221 $x -= ( ( $x >> 1 ) & 0x55555555 );
222 $x = ( ( ( $x >> 2 ) & 0x33333333 ) + ( $x & 0x33333333 ) );
223 $x = ( ( ( $x >> 4 ) + $x ) & 0x0f0f0f0f );
224 $x += ( $x >> 8 );
225 $x += ( $x >> 16 );
226 return ( $x & 0x0000003f );
227 }
228
229 sub floor_log2_pt #(register unsigned int x)
230 {
231 my $x = shift;
232 $x |= ( $x >> 1 );
233 $x |= ( $x >> 2 );
234 $x |= ( $x >> 4 );
235 $x |= ( $x >> 8 );
236 $x |= ( $x >> 16 );
237
238 #ifdef LOG0UNDEFINED
239 return ( unpack( '%32b*', pack( 'I*', $x ) ) - 1 );
240
241 #else
242 # return(ones32($x >> 1));
243 #endif
244 }
245
246 # --------------------------------------------------------------
247
248 # TEST
249
250 sub log2_LL { # gold standard
251
252 # my $n = shift; -- wastes 4% !!
253 return log(shift) / log(2);
254 }
255
256 require 5.010; # 5.9.4
257 use feature 'state';
258
259 sub log2_Lcs {
260 state $Le_2= log(2);
261
262 # my $n = shift;
263 return log(shift) / $Le_2;
264 }
265
266 { #block
267 my $Le_2;
268 INIT { $Le_2 = log(2); }
269
270 sub log2_Lc {
271
272 # my $n = shift;
273 return log(shift) / $Le_2;
274 }
275 } #block
276
277 #=======================================
278
279 { # block
280
281 my $log2; # func pointer
282
283 sub compare_it {
284 my ($n) = @_;
285 printf "log2(%g)", $n
286 unless $quiet;
287 my ( $n1, $n2 ) = ( $log2->($n), log2_LL($n) );
288 my $d = $n2 - $n1;
289 my $dp = 100 * $d / $n2;
290 printf "= %g ~ %g (%g; %d\%)\n", $n1, $n2, $d, $dp
291 unless $quiet;
292 }
293
294 sub test_it {
295
296 $log2 = shift;
297
298 print "\n\n$log2 : \n"
299 unless $quiet;
300 compare_it(3.1415926);
301 compare_it($_) for 2 .. 7;
302 compare_it( sqrt 2 );
303 compare_it( sqrt sqrt 2 );
304 compare_it( ( sqrt sqrt 2 )**3 );
305
306 $quiet
307 or printf "2^($_/2) " and compare_it( ( sqrt 2 )**$_ )
308 for 1 .. 4;
309 $quiet
310 or printf "2^($_/4) " and compare_it( ( sqrt sqrt 2 )**$_ )
311 for 1 .. 4;
312 $quiet
313 or printf "2^($_/8) " and compare_it( ( sqrt sqrt sqrt 2 )**$_ )
314 for 1 .. 8;
315 $quiet
316 or printf "2^-($_/8) " and compare_it( ( sqrt sqrt sqrt 2 )**-$_ )
317 for 1 .. 8;
318 $quiet or print "\n";
319
320 compare_it( 1.0 / $_ ) for 2 .. 12;
321 compare_it(0.999);
322
323 compare_it( 2**-10 );
324 compare_it( 2**+10 );
325
326 if ( !$quiet ) {
327 print "\n bads...";
328 eval { print $log2->(-1) } or print $!, $@;
329 eval { print $log2->(0) } or print $!, $@;
330 }
331 } # end test
332 } # END BLOCK
333