lib/Benchmark.pm

   1 package Benchmark;
   2
   3 =head1 NAME
   4
   5 Benchmark - benchmark running times of code
   6
   7 timethis - run a chunk of code several times
   8
   9 timethese - run several chunks of code several times
  10
  11 cmpthese - print results of timethese as a comparison chart
  12
  13 timeit - run a chunk of code and see how long it goes
  14
  15 countit - see how many times a chunk of code runs in a given time
  16
  17 =head1 SYNOPSIS
  18
  19     timethis ($count, "code");
  20
  21     # Use Perl code in strings...
  22     timethese($count, {
  23         'Name1' => '...code1...',
  24         'Name2' => '...code2...',
  25     });
  26
  27     # ... or use subroutine references.
  28     timethese($count, {
  29         'Name1' => sub { ...code1... },
  30         'Name2' => sub { ...code2... },
  31     });
  32
  33     # cmpthese can be used both ways as well
  34     cmpthese($count, {
  35         'Name1' => '...code1...',
  36         'Name2' => '...code2...',
  37     });
  38
  39     cmpthese($count, {
  40         'Name1' => sub { ...code1... },
  41         'Name2' => sub { ...code2... },
  42     });
  43
  44     # ...or in two stages
  45     $results = timethese($count,
  46         {
  47             'Name1' => sub { ...code1... },
  48             'Name2' => sub { ...code2... },
  49         },
  50         'none'
  51     );
  52     cmpthese( $results ) ;
  53
  54     $t = timeit($count, '...other code...')
  55     print "$count loops of other code took:",timestr($t),"\n";
  56
  57     $t = countit($time, '...other code...')
  58     $count = $t->iters ;
  59     print "$count loops of other code took:",timestr($t),"\n";
  60
  61 =head1 DESCRIPTION
  62
  63 The Benchmark module encapsulates a number of routines to help you
  64 figure out how long it takes to execute some code.
  65
  66 =head2 Methods
  67
  68 =over 10
  69
  70 =item new
  71
  72 Returns the current time.   Example:
  73
  74     use Benchmark;
  75     $t0 = new Benchmark;
  76     # ... your code here ...
  77     $t1 = new Benchmark;
  78     $td = timediff($t1, $t0);
  79     print "the code took:",timestr($td),"\n";
  80
  81 =item debug
  82
  83 Enables or disable debugging by setting the C<$Benchmark::Debug> flag:
  84
  85     debug Benchmark 1;
  86     $t = timeit(10, ' 5 ** $Global ');
  87     debug Benchmark 0;
  88
  89 =item iters
  90
  91 Returns the number of iterations.
  92
  93 =back
  94
  95 =head2 Standard Exports
  96
  97 The following routines will be exported into your namespace
  98 if you use the Benchmark module:
  99
 100 =over 10
 101
 102 =item timeit(COUNT, CODE)
 103
 104 Arguments: COUNT is the number of times to run the loop, and CODE is
 105 the code to run.  CODE may be either a code reference or a string to
 106 be eval'd; either way it will be run in the caller's package.
 107
 108 Returns: a Benchmark object.
 109
 110 =item timethis ( COUNT, CODE, [ TITLE, [ STYLE ]] )
 111
 112 Time COUNT iterations of CODE. CODE may be a string to eval or a
 113 code reference; either way the CODE will run in the caller's package.
 114 Results will be printed to STDOUT as TITLE followed by the times.
 115 TITLE defaults to "timethis COUNT" if none is provided. STYLE
 116 determines the format of the output, as described for timestr() below.
 117
 118 The COUNT can be zero or negative: this means the I<minimum number of
 119 CPU seconds> to run.  A zero signifies the default of 3 seconds.  For
 120 example to run at least for 10 seconds:
 121
 122         timethis(-10, $code)
 123
 124 or to run two pieces of code tests for at least 3 seconds:
 125
 126         timethese(0, { test1 => '...', test2 => '...'})
 127
 128 CPU seconds is, in UNIX terms, the user time plus the system time of
 129 the process itself, as opposed to the real (wallclock) time and the
 130 time spent by the child processes.  Less than 0.1 seconds is not
 131 accepted (-0.01 as the count, for example, will cause a fatal runtime
 132 exception).
 133
 134 Note that the CPU seconds is the B<minimum> time: CPU scheduling and
 135 other operating system factors may complicate the attempt so that a
 136 little bit more time is spent.  The benchmark output will, however,
 137 also tell the number of C<$code> runs/second, which should be a more
 138 interesting number than the actually spent seconds.
 139
 140 Returns a Benchmark object.
 141
 142 =item timethese ( COUNT, CODEHASHREF, [ STYLE ] )
 143
 144 The CODEHASHREF is a reference to a hash containing names as keys
 145 and either a string to eval or a code reference for each value.
 146 For each (KEY, VALUE) pair in the CODEHASHREF, this routine will
 147 call
 148
 149         timethis(COUNT, VALUE, KEY, STYLE)
 150
 151 The routines are called in string comparison order of KEY.
 152
 153 The COUNT can be zero or negative, see timethis().
 154
 155 Returns a hash of Benchmark objects, keyed by name.
 156
 157 =item timediff ( T1, T2 )
 158
 159 Returns the difference between two Benchmark times as a Benchmark
 160 object suitable for passing to timestr().
 161
 162 =item timestr ( TIMEDIFF, [ STYLE, [ FORMAT ] ] )
 163
 164 Returns a string that formats the times in the TIMEDIFF object in
 165 the requested STYLE. TIMEDIFF is expected to be a Benchmark object
 166 similar to that returned by timediff().
 167
 168 STYLE can be any of 'all', 'none', 'noc', 'nop' or 'auto'. 'all' shows
 169 each of the 5 times available ('wallclock' time, user time, system time,
 170 user time of children, and system time of children). 'noc' shows all
 171 except the two children times. 'nop' shows only wallclock and the
 172 two children times. 'auto' (the default) will act as 'all' unless
 173 the children times are both zero, in which case it acts as 'noc'.
 174 'none' prevents output.
 175
 176 FORMAT is the L<printf(3)>-style format specifier (without the
 177 leading '%') to use to print the times. It defaults to '5.2f'.
 178
 179 =back
 180
 181 =head2 Optional Exports
 182
 183 The following routines will be exported into your namespace
 184 if you specifically ask that they be imported:
 185
 186 =over 10
 187
 188 =item clearcache ( COUNT )
 189
 190 Clear the cached time for COUNT rounds of the null loop.
 191
 192 =item clearallcache ( )
 193
 194 Clear all cached times.
 195
 196 =item cmpthese ( COUT, CODEHASHREF, [ STYLE ] )
 197
 198 =item cmpthese ( RESULTSHASHREF )
 199
 200 Optionally calls timethese(), then outputs comparison chart.  This
 201 chart is sorted from slowest to fastest, and shows the percent
 202 speed difference between each pair of tests.  Can also be passed
 203 the data structure that timethese() returns:
 204
 205     $results = timethese( .... );
 206     cmpthese( $results );
 207
 208 Returns the data structure returned by timethese() (or passed in).
 209
 210 =item countit(TIME, CODE)
 211
 212 Arguments: TIME is the minimum length of time to run CODE for, and CODE is
 213 the code to run.  CODE may be either a code reference or a string to
 214 be eval'd; either way it will be run in the caller's package.
 215
 216 TIME is I<not> negative.  countit() will run the loop many times to
 217 calculate the speed of CODE before running it for TIME.  The actual
 218 time run for will usually be greater than TIME due to system clock
 219 resolution, so it's best to look at the number of iterations divided
 220 by the times that you are concerned with, not just the iterations.
 221
 222 Returns: a Benchmark object.
 223
 224 =item disablecache ( )
 225
 226 Disable caching of timings for the null loop. This will force Benchmark
 227 to recalculate these timings for each new piece of code timed.
 228
 229 =item enablecache ( )
 230
 231 Enable caching of timings for the null loop. The time taken for COUNT
 232 rounds of the null loop will be calculated only once for each
 233 different COUNT used.
 234
 235 =item timesum ( T1, T2 )
 236
 237 Returns the sum of two Benchmark times as a Benchmark object suitable
 238 for passing to timestr().
 239
 240 =back
 241
 242 =head1 NOTES
 243
 244 The data is stored as a list of values from the time and times
 245 functions:
 246
 247       ($real, $user, $system, $children_user, $children_system, $iters)
 248
 249 in seconds for the whole loop (not divided by the number of rounds).
 250
 251 The timing is done using time(3) and times(3).
 252
 253 Code is executed in the caller's package.
 254
 255 The time of the null loop (a loop with the same
 256 number of rounds but empty loop body) is subtracted
 257 from the time of the real loop.
 258
 259 The null loop times can be cached, the key being the
 260 number of rounds. The caching can be controlled using
 261 calls like these:
 262
 263     clearcache($key);
 264     clearallcache();
 265
 266     disablecache();
 267     enablecache();
 268
 269 Caching is off by default, as it can (usually slightly) decrease
 270 accuracy and does not usually noticably affect runtimes.
 271
 272 =head1 EXAMPLES
 273
 274 For example,
 275
 276    use Benchmark;$x=3;cmpthese(-5,{a=>sub{$x*$x},b=>sub{$x**2}})
 277
 278 outputs something like this:
 279
 280    Benchmark: running a, b, each for at least 5 CPU seconds...
 281             a: 10 wallclock secs ( 5.14 usr +  0.13 sys =  5.27 CPU) @ 3835055.60/s (n=20210743)
 282             b:  5 wallclock secs ( 5.41 usr +  0.00 sys =  5.41 CPU) @ 1574944.92/s (n=8520452)
 283           Rate    b    a
 284    b 1574945/s   -- -59%
 285    a 3835056/s 144%   --
 286
 287 while
 288
 289    use Benchmark;
 290    $x=3;
 291    $r=timethese(-5,{a=>sub{$x*$x},b=>sub{$x**2}},'none');
 292    cmpthese($r);
 293
 294 outputs something like this:
 295
 296           Rate    b    a
 297    b 1559428/s   -- -62%
 298    a 4152037/s 166%   --
 299
 300
 301 =head1 INHERITANCE
 302
 303 Benchmark inherits from no other class, except of course
 304 for Exporter.
 305
 306 =head1 CAVEATS
 307
 308 Comparing eval'd strings with code references will give you
 309 inaccurate results: a code reference will show a slightly slower
 310 execution time than the equivalent eval'd string.
 311
 312 The real time timing is done using time(2) and
 313 the granularity is therefore only one second.
 314
 315 Short tests may produce negative figures because perl
 316 can appear to take longer to execute the empty loop
 317 than a short test; try:
 318
 319     timethis(100,'1');
 320
 321 The system time of the null loop might be slightly
 322 more than the system time of the loop with the actual
 323 code and therefore the difference might end up being E<lt> 0.
 324
 325 =head1 AUTHORS
 326
 327 Jarkko Hietaniemi <F<jhi@iki.fi>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>>
 328
 329 =head1 MODIFICATION HISTORY
 330
 331 September 8th, 1994; by Tim Bunce.
 332
 333 March 28th, 1997; by Hugo van der Sanden: added support for code
 334 references and the already documented 'debug' method; revamped
 335 documentation.
 336
 337 April 04-07th, 1997: by Jarkko Hietaniemi, added the run-for-some-time
 338 functionality.
 339
 340 September, 1999; by Barrie Slaymaker: math fixes and accuracy and
 341 efficiency tweaks.  Added cmpthese().  A result is now returned from
 342 timethese().  Exposed countit() (was runfor()).
 343
 344 =cut
 345
 346 # evaluate something in a clean lexical environment
 347 sub _doeval { eval shift }
 348
 349 #
 350 # put any lexicals at file scope AFTER here
 351 #
 352
 353 use Carp;
 354 use Exporter;
 355 @ISA=(Exporter);
 356 @EXPORT=qw(timeit timethis timethese timediff timestr);
 357 @EXPORT_OK=qw(timesum cmpthese countit
 358               clearcache clearallcache disablecache enablecache);
 359
 360 &init;
 361
 362 sub init {
 363     $debug = 0;
 364     $min_count = 4;
 365     $min_cpu   = 0.4;
 366     $defaultfmt = '5.2f';
 367     $defaultstyle = 'auto';
 368     # The cache can cause a slight loss of sys time accuracy. If a
 369     # user does many tests (>10) with *very* large counts (>10000)
 370     # or works on a very slow machine the cache may be useful.
 371     &disablecache;
 372     &clearallcache;
 373 }
 374
 375 sub debug { $debug = ($_[1] != 0); }
 376
 377 # The cache needs two branches: 's' for strings and 'c' for code.  The
 378 # emtpy loop is different in these two cases.
 379 sub clearcache    { delete $cache{"$_[0]c"}; delete $cache{"$_[0]s"}; }
 380 sub clearallcache { %cache = (); }
 381 sub enablecache   { $cache = 1; }
 382 sub disablecache  { $cache = 0; }
 383
 384 # --- Functions to process the 'time' data type
 385
 386 sub new { my @t = (time, times, @_ == 2 ? $_[1] : 0);
 387           print "new=@t\n" if $debug;
 388           bless \@t; }
 389
 390 sub cpu_p { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps         ; }
 391 sub cpu_c { my($r,$pu,$ps,$cu,$cs) = @{$_[0]};         $cu+$cs ; }
 392 sub cpu_a { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps+$cu+$cs ; }
 393 sub real  { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $r              ; }
 394 sub iters { $_[0]->[5] ; }
 395
 396 sub timediff {
 397     my($a, $b) = @_;
 398     my @r;
 399     for (my $i=0; $i < @$a; ++$i) {
 400         push(@r, $a->[$i] - $b->[$i]);
 401     }
 402     bless \@r;
 403 }
 404
 405 sub timesum {
 406      my($a, $b) = @_;
 407      my @r;
 408      for (my $i=0; $i < @$a; ++$i) {
 409         push(@r, $a->[$i] + $b->[$i]);
 410      }
 411      bless \@r;
 412 }
 413
 414 sub timestr {
 415     my($tr, $style, $f) = @_;
 416     my @t = @$tr;
 417     warn "bad time value (@t)" unless @t==6;
 418     my($r, $pu, $ps, $cu, $cs, $n) = @t;
 419     my($pt, $ct, $t) = ($tr->cpu_p, $tr->cpu_c, $tr->cpu_a);
 420     $f = $defaultfmt unless defined $f;
 421     # format a time in the required style, other formats may be added here
 422     $style ||= $defaultstyle;
 423     $style = ($ct>0) ? 'all' : 'noc' if $style eq 'auto';
 424     my $s = "@t $style"; # default for unknown style
 425     $s=sprintf("%2d wallclock secs (%$f usr %$f sys + %$f cusr %$f csys = %$f CPU)",
 426                             @t,$t) if $style eq 'all';
 427     $s=sprintf("%2d wallclock secs (%$f usr + %$f sys = %$f CPU)",
 428                             $r,$pu,$ps,$pt) if $style eq 'noc';
 429     $s=sprintf("%2d wallclock secs (%$f cusr + %$f csys = %$f CPU)",
 430                             $r,$cu,$cs,$ct) if $style eq 'nop';
 431     $s .= sprintf(" @ %$f/s (n=$n)", $n / ( $pu + $ps )) if $n;
 432     $s;
 433 }
 434
 435 sub timedebug {
 436     my($msg, $t) = @_;
 437     print STDERR "$msg",timestr($t),"\n" if $debug;
 438 }
 439
 440 # --- Functions implementing low-level support for timing loops
 441
 442 sub runloop {
 443     my($n, $c) = @_;
 444
 445     $n+=0; # force numeric now, so garbage won't creep into the eval
 446     croak "negative loopcount $n" if $n<0;
 447     confess "Usage: runloop(number, [string | coderef])" unless defined $c;
 448     my($t0, $t1, $td); # before, after, difference
 449
 450     # find package of caller so we can execute code there
 451     my($curpack) = caller(0);
 452     my($i, $pack)= 0;
 453     while (($pack) = caller(++$i)) {
 454         last if $pack ne $curpack;
 455     }
 456
 457     my ($subcode, $subref);
 458     if (ref $c eq 'CODE') {
 459         $subcode = "sub { for (1 .. $n) { local \$_; package $pack; &\$c; } }";
 460         $subref  = eval $subcode;
 461     }
 462     else {
 463         $subcode = "sub { for (1 .. $n) { local \$_; package $pack; $c;} }";
 464         $subref  = _doeval($subcode);
 465     }
 466     croak "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@;
 467     print STDERR "runloop $n '$subcode'\n" if $debug;
 468
 469     # Wait for the user timer to tick.  This makes the error range more like
 470     # -0.01, +0.  If we don't wait, then it's more like -0.01, +0.01.  This
 471     # may not seem important, but it significantly reduces the chances of
 472     # getting a too low initial $n in the initial, 'find the minimum' loop
 473     # in &countit.  This, in turn, can reduce the number of calls to
 474     # &runloop a lot, and thus reduce additive errors.
 475     my $tbase = Benchmark->new(0)->[1];
 476     while ( ( $t0 = Benchmark->new(0) )->[1] == $tbase ) {} ;
 477     &$subref;
 478     $t1 = Benchmark->new($n);
 479     $td = &timediff($t1, $t0);
 480     timedebug("runloop:",$td);
 481     $td;
 482 }
 483
 484
 485 sub timeit {
 486     my($n, $code) = @_;
 487     my($wn, $wc, $wd);
 488
 489     printf STDERR "timeit $n $code\n" if $debug;
 490     my $cache_key = $n . ( ref( $code ) ? 'c' : 's' );
 491     if ($cache && exists $cache{$cache_key} ) {
 492         $wn = $cache{$cache_key};
 493     } else {
 494         $wn = &runloop($n, ref( $code ) ? sub { undef } : '' );
 495         # Can't let our baseline have any iterations, or they get subtracted
 496         # out of the result.
 497         $wn->[5] = 0;
 498         $cache{$cache_key} = $wn;
 499     }
 500
 501     $wc = &runloop($n, $code);
 502
 503     $wd = timediff($wc, $wn);
 504     timedebug("timeit: ",$wc);
 505     timedebug("      - ",$wn);
 506     timedebug("      = ",$wd);
 507
 508     $wd;
 509 }
 510
 511
 512 my $default_for = 3;
 513 my $min_for     = 0.1;
 514
 515
 516 sub countit {
 517     my ( $tmax, $code ) = @_;
 518
 519     if ( not defined $tmax or $tmax == 0 ) {
 520         $tmax = $default_for;
 521     } elsif ( $tmax < 0 ) {
 522         $tmax = -$tmax;
 523     }
 524
 525     die "countit($tmax, ...): timelimit cannot be less than $min_for.\n"
 526         if $tmax < $min_for;
 527
 528     my ($n, $tc);
 529
 530     # First find the minimum $n that gives a significant timing.
 531     for ($n = 1; ; $n *= 2 ) {
 532         my $td = timeit($n, $code);
 533         $tc = $td->[1] + $td->[2];
 534         last if $tc > 0.1;
 535     }
 536
 537     my $nmin = $n;
 538
 539     # Get $n high enough that we can guess the final $n with some accuracy.
 540     my $tpra = 0.1 * $tmax; # Target/time practice.
 541     while ( $tc < $tpra ) {
 542         # The 5% fudge is to keep us from iterating again all
 543         # that often (this speeds overall responsiveness when $tmax is big
 544         # and we guess a little low).  This does not noticably affect
 545         # accuracy since we're not couting these times.
 546         $n = int( $tpra * 1.05 * $n / $tc ); # Linear approximation.
 547         my $td = timeit($n, $code);
 548         $tc = $td->[1] + $td->[2];
 549     }
 550
 551     # Now, do the 'for real' timing(s), repeating until we exceed
 552     # the max.
 553     my $ntot  = 0;
 554     my $rtot  = 0;
 555     my $utot  = 0.0;
 556     my $stot  = 0.0;
 557     my $cutot = 0.0;
 558     my $cstot = 0.0;
 559     my $ttot  = 0.0;
 560
 561     # The 5% fudge is because $n is often a few % low even for routines
 562     # with stable times and avoiding extra timeit()s is nice for
 563     # accuracy's sake.
 564     $n = int( $n * ( 1.05 * $tmax / $tc ) );
 565
 566     while () {
 567         my $td = timeit($n, $code);
 568         $ntot  += $n;
 569         $rtot  += $td->[0];
 570         $utot  += $td->[1];
 571         $stot  += $td->[2];
 572         $cutot += $td->[3];
 573         $cstot += $td->[4];
 574         $ttot = $utot + $stot;
 575         last if $ttot >= $tmax;
 576
 577         my $r = $tmax / $ttot - 1; # Linear approximation.
 578         $n = int( $r * $ntot );
 579         $n = $nmin if $n < $nmin;
 580     }
 581
 582     return bless [ $rtot, $utot, $stot, $cutot, $cstot, $ntot ];
 583 }
 584
 585 # --- Functions implementing high-level time-then-print utilities
 586
 587 sub n_to_for {
 588     my $n = shift;
 589     return $n == 0 ? $default_for : $n < 0 ? -$n : undef;
 590 }
 591
 592 sub timethis{
 593     my($n, $code, $title, $style) = @_;
 594     my($t, $for, $forn);
 595
 596     if ( $n > 0 ) {
 597         croak "non-integer loopcount $n, stopped" if int($n)<$n;
 598         $t = timeit($n, $code);
 599         $title = "timethis $n" unless defined $title;
 600     } else {
 601         $fort  = n_to_for( $n );
 602         $t     = countit( $fort, $code );
 603         $title = "timethis for $fort" unless defined $title;
 604         $forn  = $t->[-1];
 605     }
 606     local $| = 1;
 607     $style = "" unless defined $style;
 608     printf("%10s: ", $title) unless $style eq 'none';
 609     print timestr($t, $style, $defaultfmt),"\n" unless $style eq 'none';
 610
 611     $n = $forn if defined $forn;
 612
 613     # A conservative warning to spot very silly tests.
 614     # Don't assume that your benchmark is ok simply because
 615     # you don't get this warning!
 616     print "            (warning: too few iterations for a reliable count)\n"
 617         if     $n < $min_count
 618             || ($t->real < 1 && $n < 1000)
 619             || $t->cpu_a < $min_cpu;
 620     $t;
 621 }
 622
 623 sub timethese{
 624     my($n, $alt, $style) = @_;
 625     die "usage: timethese(count, { 'Name1'=>'code1', ... }\n"
 626                 unless ref $alt eq HASH;
 627     my @names = sort keys %$alt;
 628     $style = "" unless defined $style;
 629     print "Benchmark: " unless $style eq 'none';
 630     if ( $n > 0 ) {
 631         croak "non-integer loopcount $n, stopped" if int($n)<$n;
 632         print "timing $n iterations of" unless $style eq 'none';
 633     } else {
 634         print "running" unless $style eq 'none';
 635     }
 636     print " ", join(', ',@names) unless $style eq 'none';
 637     unless ( $n > 0 ) {
 638         my $for = n_to_for( $n );
 639         print ", each for at least $for CPU seconds" unless $style eq 'none';
 640     }
 641     print "...\n" unless $style eq 'none';
 642
 643     # we could save the results in an array and produce a summary here
 644     # sum, min, max, avg etc etc
 645     my %results;
 646     foreach my $name (@names) {
 647         $results{$name} = timethis ($n, $alt -> {$name}, $name, $style);
 648     }
 649
 650     return \%results;
 651 }
 652
 653 sub cmpthese{
 654     my $results = ref $_[0] ? $_[0] : timethese( @_ );
 655
 656     return $results
 657        if defined $_[2] && $_[2] eq 'none';
 658
 659     # Flatten in to an array of arrays with the name as the first field
 660     my @vals = map{ [ $_, @{$results->{$_}} ] } keys %$results;
 661
 662     for (@vals) {
 663         # The epsilon fudge here is to prevent div by 0.  Since clock
 664         # resolutions are much larger, it's below the noise floor.
 665         my $rate = $_->[6] / ( $_->[2] + $_->[3] + 0.000000000000001 );
 666         $_->[7] = $rate;
 667     }
 668
 669     # Sort by rate
 670     @vals = sort { $a->[7] <=> $b->[7] } @vals;
 671
 672     # If more than half of the rates are greater than one...
 673     my $display_as_rate = $vals[$#vals>>1]->[7] > 1;
 674
 675     my @rows;
 676     my @col_widths;
 677
 678     my @top_row = (
 679         '',
 680         $display_as_rate ? 'Rate' : 's/iter',
 681         map { $_->[0] } @vals
 682     );
 683
 684     push @rows, \@top_row;
 685     @col_widths = map { length( $_ ) } @top_row;
 686
 687     # Build the data rows
 688     # We leave the last column in even though it never has any data.  Perhaps
 689     # it should go away.  Also, perhaps a style for a single column of
 690     # percentages might be nice.
 691     for my $row_val ( @vals ) {
 692         my @row;
 693
 694         # Column 0 = test name
 695         push @row, $row_val->[0];
 696         $col_widths[0] = length( $row_val->[0] )
 697             if length( $row_val->[0] ) > $col_widths[0];
 698
 699         # Column 1 = performance
 700         my $row_rate = $row_val->[7];
 701
 702         # We assume that we'll never get a 0 rate.
 703         my $a = $display_as_rate ? $row_rate : 1 / $row_rate;
 704
 705         # Only give a few decimal places before switching to sci. notation,
 706         # since the results aren't usually that accurate anyway.
 707         my $format =
 708            $a >= 100 ?
 709                "%0.0f" :
 710            $a >= 10 ?
 711                "%0.1f" :
 712            $a >= 1 ?
 713                "%0.2f" :
 714            $a >= 0.1 ?
 715                "%0.3f" :
 716                "%0.2e";
 717
 718         $format .= "/s"
 719             if $display_as_rate;
 720         # Using $b here due to optimizing bug in _58 through _61
 721         my $b = sprintf( $format, $a );
 722         push @row, $b;
 723         $col_widths[1] = length( $b )
 724             if length( $b ) > $col_widths[1];
 725
 726         # Columns 2..N = performance ratios
 727         my $skip_rest = 0;
 728         for ( my $col_num = 0 ; $col_num < @vals ; ++$col_num ) {
 729             my $col_val = $vals[$col_num];
 730             my $out;
 731             if ( $skip_rest ) {
 732                 $out = '';
 733             }
 734             elsif ( $col_val->[0] eq $row_val->[0] ) {
 735                 $out = "--";
 736                 # $skip_rest = 1;
 737             }
 738             else {
 739                 my $col_rate = $col_val->[7];
 740                 $out = sprintf( "%.0f%%", 100*$row_rate/$col_rate - 100 );
 741             }
 742             push @row, $out;
 743             $col_widths[$col_num+2] = length( $out )
 744                 if length( $out ) > $col_widths[$col_num+2];
 745
 746             # A little wierdness to set the first column width properly
 747             $col_widths[$col_num+2] = length( $col_val->[0] )
 748                 if length( $col_val->[0] ) > $col_widths[$col_num+2];
 749         }
 750         push @rows, \@row;
 751     }
 752
 753     # Equalize column widths in the chart as much as possible without
 754     # exceeding 80 characters.  This does not use or affect cols 0 or 1.
 755     my @sorted_width_refs =
 756        sort { $$a <=> $$b } map { \$_ } @col_widths[2..$#col_widths];
 757     my $max_width = ${$sorted_width_refs[-1]};
 758
 759     my $total = @col_widths - 1 ;
 760     for ( @col_widths ) { $total += $_ }
 761
 762     STRETCHER:
 763     while ( $total < 80 ) {
 764         my $min_width = ${$sorted_width_refs[0]};
 765         last
 766            if $min_width == $max_width;
 767         for ( @sorted_width_refs ) {
 768             last
 769                 if $$_ > $min_width;
 770             ++$$_;
 771             ++$total;
 772             last STRETCHER
 773                 if $total >= 80;
 774         }
 775     }
 776
 777     # Dump the output
 778     my $format = join( ' ', map { "%${_}s" } @col_widths ) . "\n";
 779     substr( $format, 1, 0 ) = '-';
 780     for ( @rows ) {
 781         printf $format, @$_;
 782     }
 783
 784     return $results;
 785 }
 786
 787
 788 1;