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