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