lib/Benchmark.pm

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