extra code in pp_concat, Take 2
[p5sagit/p5-mst-13.2.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 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.07;
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         *mytime = $hirestime if defined $hirestime;
460     }
461     Benchmark->export_to_level(1, $class, @_);
462 }
463
464 our($Debug, $Min_Count, $Min_CPU, $Default_Format, $Default_Style,
465     %_Usage, %Cache, $Do_Cache);
466
467 sub init {
468     $Debug = 0;
469     $Min_Count = 4;
470     $Min_CPU   = 0.4;
471     $Default_Format = '5.2f';
472     $Default_Style = 'auto';
473     # The cache can cause a slight loss of sys time accuracy. If a
474     # user does many tests (>10) with *very* large counts (>10000)
475     # or works on a very slow machine the cache may be useful.
476     disablecache();
477     clearallcache();
478 }
479
480 sub debug { $Debug = ($_[1] != 0); }
481
482 sub usage { 
483     my $calling_sub = (caller(1))[3];
484     $calling_sub =~ s/^Benchmark:://;
485     return $_Usage{$calling_sub} || '';
486 }
487
488 # The cache needs two branches: 's' for strings and 'c' for code.  The
489 # empty loop is different in these two cases.
490
491 $_Usage{clearcache} = <<'USAGE';
492 usage: clearcache($count);
493 USAGE
494
495 sub clearcache    { 
496     die usage unless @_ == 1;
497     delete $Cache{"$_[0]c"}; delete $Cache{"$_[0]s"}; 
498 }
499
500 $_Usage{clearallcache} = <<'USAGE';
501 usage: clearallcache();
502 USAGE
503
504 sub clearallcache { 
505     die usage if @_;
506     %Cache = (); 
507 }
508
509 $_Usage{enablecache} = <<'USAGE';
510 usage: enablecache();
511 USAGE
512
513 sub enablecache   {
514     die usage if @_;
515     $Do_Cache = 1; 
516 }
517
518 $_Usage{disablecache} = <<'USAGE';
519 usage: disablecache();
520 USAGE
521
522 sub disablecache  {
523     die usage if @_;
524     $Do_Cache = 0; 
525 }
526
527
528 # --- Functions to process the 'time' data type
529
530 sub new { my @t = (mytime, times, @_ == 2 ? $_[1] : 0);
531           print STDERR "new=@t\n" if $Debug;
532           bless \@t; }
533
534 sub cpu_p { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps         ; }
535 sub cpu_c { my($r,$pu,$ps,$cu,$cs) = @{$_[0]};         $cu+$cs ; }
536 sub cpu_a { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps+$cu+$cs ; }
537 sub real  { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $r              ; }
538 sub iters { $_[0]->[5] ; }
539
540
541 $_Usage{timediff} = <<'USAGE';
542 usage: $result_diff = timediff($result1, $result2);
543 USAGE
544
545 sub timediff {
546     my($a, $b) = @_;
547
548     die usage unless ref $a and ref $b;
549
550     my @r;
551     for (my $i=0; $i < @$a; ++$i) {
552         push(@r, $a->[$i] - $b->[$i]);
553     }
554     bless \@r;
555 }
556
557 $_Usage{timesum} = <<'USAGE';
558 usage: $sum = timesum($result1, $result2);
559 USAGE
560
561 sub timesum {
562     my($a, $b) = @_;
563
564     die usage unless ref $a and ref $b;
565
566     my @r;
567     for (my $i=0; $i < @$a; ++$i) {
568         push(@r, $a->[$i] + $b->[$i]);
569     }
570     bless \@r;
571 }
572
573
574 $_Usage{timestr} = <<'USAGE';
575 usage: $formatted_result = timestr($result1);
576 USAGE
577
578 sub timestr {
579     my($tr, $style, $f) = @_;
580
581     die usage unless ref $tr;
582
583     my @t = @$tr;
584     warn "bad time value (@t)" unless @t==6;
585     my($r, $pu, $ps, $cu, $cs, $n) = @t;
586     my($pt, $ct, $tt) = ($tr->cpu_p, $tr->cpu_c, $tr->cpu_a);
587     $f = $Default_Format unless defined $f;
588     # format a time in the required style, other formats may be added here
589     $style ||= $Default_Style;
590     return '' if $style eq 'none';
591     $style = ($ct>0) ? 'all' : 'noc' if $style eq 'auto';
592     my $s = "@t $style"; # default for unknown style
593     my $w = $hirestime ? "%2g" : "%2d";
594     $s=sprintf("$w wallclock secs (%$f usr %$f sys + %$f cusr %$f csys = %$f CPU)",
595                             $r,$pu,$ps,$cu,$cs,$tt) if $style eq 'all';
596     $s=sprintf("$w wallclock secs (%$f usr + %$f sys = %$f CPU)",
597                             $r,$pu,$ps,$pt) if $style eq 'noc';
598     $s=sprintf("$w wallclock secs (%$f cusr + %$f csys = %$f CPU)",
599                             $r,$cu,$cs,$ct) if $style eq 'nop';
600     $s .= sprintf(" @ %$f/s (n=$n)", $n / ( $style eq 'nop' ? $cu + $cs : $pu + $ps ))
601         if $n && ($style eq 'nop' ? $cu+$cs : $pu+$ps);
602     $s;
603 }
604
605 sub timedebug {
606     my($msg, $t) = @_;
607     print STDERR "$msg",timestr($t),"\n" if $Debug;
608 }
609
610 # --- Functions implementing low-level support for timing loops
611
612 $_Usage{runloop} = <<'USAGE';
613 usage: runloop($number, [$string | $coderef])
614 USAGE
615
616 sub runloop {
617     my($n, $c) = @_;
618
619     $n+=0; # force numeric now, so garbage won't creep into the eval
620     croak "negative loopcount $n" if $n<0;
621     confess usage unless defined $c;
622     my($t0, $t1, $td); # before, after, difference
623
624     # find package of caller so we can execute code there
625     my($curpack) = caller(0);
626     my($i, $pack)= 0;
627     while (($pack) = caller(++$i)) {
628         last if $pack ne $curpack;
629     }
630
631     my ($subcode, $subref);
632     if (ref $c eq 'CODE') {
633         $subcode = "sub { for (1 .. $n) { local \$_; package $pack; &\$c; } }";
634         $subref  = eval $subcode;
635     }
636     else {
637         $subcode = "sub { for (1 .. $n) { local \$_; package $pack; $c;} }";
638         $subref  = _doeval($subcode);
639     }
640     croak "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@;
641     print STDERR "runloop $n '$subcode'\n" if $Debug;
642
643     # Wait for the user timer to tick.  This makes the error range more like 
644     # -0.01, +0.  If we don't wait, then it's more like -0.01, +0.01.  This
645     # may not seem important, but it significantly reduces the chances of
646     # getting a too low initial $n in the initial, 'find the minimum' loop
647     # in &countit.  This, in turn, can reduce the number of calls to
648     # &runloop a lot, and thus reduce additive errors.
649     my $tbase = Benchmark->new(0)->[1];
650     while ( ( $t0 = Benchmark->new(0) )->[1] == $tbase ) {} ;
651     $subref->();
652     $t1 = Benchmark->new($n);
653     $td = &timediff($t1, $t0);
654     timedebug("runloop:",$td);
655     $td;
656 }
657
658 $_Usage{timeit} = <<'USAGE';
659 usage: $result = timeit($count, 'code' );        or
660        $result = timeit($count, sub { code } );
661 USAGE
662
663 sub timeit {
664     my($n, $code) = @_;
665     my($wn, $wc, $wd);
666
667     die usage unless defined $code and
668                      (!ref $code or ref $code eq 'CODE');
669
670     printf STDERR "timeit $n $code\n" if $Debug;
671     my $cache_key = $n . ( ref( $code ) ? 'c' : 's' );
672     if ($Do_Cache && exists $Cache{$cache_key} ) {
673         $wn = $Cache{$cache_key};
674     } else {
675         $wn = &runloop($n, ref( $code ) ? sub { } : '' );
676         # Can't let our baseline have any iterations, or they get subtracted
677         # out of the result.
678         $wn->[5] = 0;
679         $Cache{$cache_key} = $wn;
680     }
681
682     $wc = &runloop($n, $code);
683
684     $wd = timediff($wc, $wn);
685     timedebug("timeit: ",$wc);
686     timedebug("      - ",$wn);
687     timedebug("      = ",$wd);
688
689     $wd;
690 }
691
692
693 my $default_for = 3;
694 my $min_for     = 0.1;
695
696
697 $_Usage{countit} = <<'USAGE';
698 usage: $result = countit($time, 'code' );        or
699        $result = countit($time, sub { code } );
700 USAGE
701
702 sub countit {
703     my ( $tmax, $code ) = @_;
704
705     die usage unless @_;
706
707     if ( not defined $tmax or $tmax == 0 ) {
708         $tmax = $default_for;
709     } elsif ( $tmax < 0 ) {
710         $tmax = -$tmax;
711     }
712
713     die "countit($tmax, ...): timelimit cannot be less than $min_for.\n"
714         if $tmax < $min_for;
715
716     my ($n, $tc);
717
718     # First find the minimum $n that gives a significant timing.
719     for ($n = 1; ; $n *= 2 ) {
720         my $td = timeit($n, $code);
721         $tc = $td->[1] + $td->[2];
722         last if $tc > 0.1;
723     }
724
725     my $nmin = $n;
726
727     # Get $n high enough that we can guess the final $n with some accuracy.
728     my $tpra = 0.1 * $tmax; # Target/time practice.
729     while ( $tc < $tpra ) {
730         # The 5% fudge is to keep us from iterating again all
731         # that often (this speeds overall responsiveness when $tmax is big
732         # and we guess a little low).  This does not noticably affect 
733         # accuracy since we're not couting these times.
734         $n = int( $tpra * 1.05 * $n / $tc ); # Linear approximation.
735         my $td = timeit($n, $code);
736         my $new_tc = $td->[1] + $td->[2];
737         # Make sure we are making progress.
738         $tc = $new_tc > 1.2 * $tc ? $new_tc : 1.2 * $tc;
739     }
740
741     # Now, do the 'for real' timing(s), repeating until we exceed
742     # the max.
743     my $ntot  = 0;
744     my $rtot  = 0;
745     my $utot  = 0.0;
746     my $stot  = 0.0;
747     my $cutot = 0.0;
748     my $cstot = 0.0;
749     my $ttot  = 0.0;
750
751     # The 5% fudge is because $n is often a few % low even for routines
752     # with stable times and avoiding extra timeit()s is nice for
753     # accuracy's sake.
754     $n = int( $n * ( 1.05 * $tmax / $tc ) );
755
756     while () {
757         my $td = timeit($n, $code);
758         $ntot  += $n;
759         $rtot  += $td->[0];
760         $utot  += $td->[1];
761         $stot  += $td->[2];
762         $cutot += $td->[3];
763         $cstot += $td->[4];
764         $ttot = $utot + $stot;
765         last if $ttot >= $tmax;
766
767         $ttot = 0.01 if $ttot < 0.01;
768         my $r = $tmax / $ttot - 1; # Linear approximation.
769         $n = int( $r * $ntot );
770         $n = $nmin if $n < $nmin;
771     }
772
773     return bless [ $rtot, $utot, $stot, $cutot, $cstot, $ntot ];
774 }
775
776 # --- Functions implementing high-level time-then-print utilities
777
778 sub n_to_for {
779     my $n = shift;
780     return $n == 0 ? $default_for : $n < 0 ? -$n : undef;
781 }
782
783 $_Usage{timethis} = <<'USAGE';
784 usage: $result = timethis($time, 'code' );        or
785        $result = timethis($time, sub { code } );
786 USAGE
787
788 sub timethis{
789     my($n, $code, $title, $style) = @_;
790     my($t, $forn);
791
792     die usage unless defined $code and
793                      (!ref $code or ref $code eq 'CODE');
794
795     if ( $n > 0 ) {
796         croak "non-integer loopcount $n, stopped" if int($n)<$n;
797         $t = timeit($n, $code);
798         $title = "timethis $n" unless defined $title;
799     } else {
800         my $fort  = n_to_for( $n );
801         $t     = countit( $fort, $code );
802         $title = "timethis for $fort" unless defined $title;
803         $forn  = $t->[-1];
804     }
805     local $| = 1;
806     $style = "" unless defined $style;
807     printf("%10s: ", $title) unless $style eq 'none';
808     print timestr($t, $style, $Default_Format),"\n" unless $style eq 'none';
809
810     $n = $forn if defined $forn;
811
812     # A conservative warning to spot very silly tests.
813     # Don't assume that your benchmark is ok simply because
814     # you don't get this warning!
815     print "            (warning: too few iterations for a reliable count)\n"
816         if     $n < $Min_Count
817             || ($t->real < 1 && $n < 1000)
818             || $t->cpu_a < $Min_CPU;
819     $t;
820 }
821
822
823 $_Usage{timethese} = <<'USAGE';
824 usage: timethese($count, { Name1 => 'code1', ... });        or
825        timethese($count, { Name1 => sub { code1 }, ... });
826 USAGE
827
828 sub timethese{
829     my($n, $alt, $style) = @_;
830     die usage unless ref $alt eq 'HASH';
831
832     my @names = sort keys %$alt;
833     $style = "" unless defined $style;
834     print "Benchmark: " unless $style eq 'none';
835     if ( $n > 0 ) {
836         croak "non-integer loopcount $n, stopped" if int($n)<$n;
837         print "timing $n iterations of" unless $style eq 'none';
838     } else {
839         print "running" unless $style eq 'none';
840     }
841     print " ", join(', ',@names) unless $style eq 'none';
842     unless ( $n > 0 ) {
843         my $for = n_to_for( $n );
844         print ", each" if $n > 1 && $style ne 'none';
845         print " for at least $for CPU seconds" unless $style eq 'none';
846     }
847     print "...\n" unless $style eq 'none';
848
849     # we could save the results in an array and produce a summary here
850     # sum, min, max, avg etc etc
851     my %results;
852     foreach my $name (@names) {
853         $results{$name} = timethis ($n, $alt -> {$name}, $name, $style);
854     }
855
856     return \%results;
857 }
858
859
860 $_Usage{cmpthese} = <<'USAGE';
861 usage: cmpthese($count, { Name1 => 'code1', ... });        or
862        cmpthese($count, { Name1 => sub { code1 }, ... });  or
863        cmpthese($result, $style);
864 USAGE
865
866 sub cmpthese{
867     my ($results, $style);
868
869     if( ref $_[0] ) {
870         ($results, $style) = @_;
871     }
872     else {
873         my($count, $code) = @_[0,1];
874         $style = $_[2] if defined $_[2];
875
876         die usage unless ref $code eq 'HASH';
877
878         $results = timethese($count, $code, ($style || "none"));
879     }
880
881     $style = "" unless defined $style;
882
883     # Flatten in to an array of arrays with the name as the first field
884     my @vals = map{ [ $_, @{$results->{$_}} ] } keys %$results;
885
886     for (@vals) {
887         # The epsilon fudge here is to prevent div by 0.  Since clock
888         # resolutions are much larger, it's below the noise floor.
889         my $rate = $_->[6] / (( $style eq 'nop' ? $_->[4] + $_->[5]
890                                                 : $_->[2] + $_->[3]) + 0.000000000000001 );
891         $_->[7] = $rate;
892     }
893
894     # Sort by rate
895     @vals = sort { $a->[7] <=> $b->[7] } @vals;
896
897     # If more than half of the rates are greater than one...
898     my $display_as_rate = @vals ? ($vals[$#vals>>1]->[7] > 1) : 0;
899
900     my @rows;
901     my @col_widths;
902
903     my @top_row = ( 
904         '', 
905         $display_as_rate ? 'Rate' : 's/iter', 
906         map { $_->[0] } @vals 
907     );
908
909     push @rows, \@top_row;
910     @col_widths = map { length( $_ ) } @top_row;
911
912     # Build the data rows
913     # We leave the last column in even though it never has any data.  Perhaps
914     # it should go away.  Also, perhaps a style for a single column of
915     # percentages might be nice.
916     for my $row_val ( @vals ) {
917         my @row;
918
919         # Column 0 = test name
920         push @row, $row_val->[0];
921         $col_widths[0] = length( $row_val->[0] )
922             if length( $row_val->[0] ) > $col_widths[0];
923
924         # Column 1 = performance
925         my $row_rate = $row_val->[7];
926
927         # We assume that we'll never get a 0 rate.
928         my $rate = $display_as_rate ? $row_rate : 1 / $row_rate;
929
930         # Only give a few decimal places before switching to sci. notation,
931         # since the results aren't usually that accurate anyway.
932         my $format = 
933            $rate >= 100 ? 
934                "%0.0f" : 
935            $rate >= 10 ?
936                "%0.1f" :
937            $rate >= 1 ?
938                "%0.2f" :
939            $rate >= 0.1 ?
940                "%0.3f" :
941                "%0.2e";
942
943         $format .= "/s"
944             if $display_as_rate;
945
946         my $formatted_rate = sprintf( $format, $rate );
947         push @row, $formatted_rate;
948         $col_widths[1] = length( $formatted_rate )
949             if length( $formatted_rate ) > $col_widths[1];
950
951         # Columns 2..N = performance ratios
952         my $skip_rest = 0;
953         for ( my $col_num = 0 ; $col_num < @vals ; ++$col_num ) {
954             my $col_val = $vals[$col_num];
955             my $out;
956             if ( $skip_rest ) {
957                 $out = '';
958             }
959             elsif ( $col_val->[0] eq $row_val->[0] ) {
960                 $out = "--";
961                 # $skip_rest = 1;
962             }
963             else {
964                 my $col_rate = $col_val->[7];
965                 $out = sprintf( "%.0f%%", 100*$row_rate/$col_rate - 100 );
966             }
967             push @row, $out;
968             $col_widths[$col_num+2] = length( $out )
969                 if length( $out ) > $col_widths[$col_num+2];
970
971             # A little wierdness to set the first column width properly
972             $col_widths[$col_num+2] = length( $col_val->[0] )
973                 if length( $col_val->[0] ) > $col_widths[$col_num+2];
974         }
975         push @rows, \@row;
976     }
977
978     return \@rows if $style eq "none";
979
980     # Equalize column widths in the chart as much as possible without
981     # exceeding 80 characters.  This does not use or affect cols 0 or 1.
982     my @sorted_width_refs = 
983        sort { $$a <=> $$b } map { \$_ } @col_widths[2..$#col_widths];
984     my $max_width = ${$sorted_width_refs[-1]};
985
986     my $total = @col_widths - 1 ;
987     for ( @col_widths ) { $total += $_ }
988
989     STRETCHER:
990     while ( $total < 80 ) {
991         my $min_width = ${$sorted_width_refs[0]};
992         last
993            if $min_width == $max_width;
994         for ( @sorted_width_refs ) {
995             last 
996                 if $$_ > $min_width;
997             ++$$_;
998             ++$total;
999             last STRETCHER
1000                 if $total >= 80;
1001         }
1002     }
1003
1004     # Dump the output
1005     my $format = join( ' ', map { "%${_}s" } @col_widths ) . "\n";
1006     substr( $format, 1, 0 ) = '-';
1007     for ( @rows ) {
1008         printf $format, @$_;
1009     }
1010
1011     return \@rows ;
1012 }
1013
1014
1015 1;