perl 5.000perl-5.000

[editor's note: this commit combines approximate 4 months of furious
releases of Andy Dougherty and Larry Wall - see pod/perlhist.pod for
details.  Andy notes that;
 
Alas neither my "Irwin AccuTrack" nor my DC 600A quarter-inch cartridge 
backup tapes from that era seem to be readable anymore.  I guess 13 years 
exceeds the shelf life for that backup technology :-(.
]

1 files changed, 245 insertions, 0 deletions

diff --git a/lib/Benchmark.pm b/lib/Benchmark.pm
new file mode 100644
index 0000000000..a19caffdc8
--- /dev/null
+++ b/lib/Benchmark.pm
@@ -0,0 +1,245 @@
+package Benchmark;
+
+# Purpose: benchmark running times of code.
+#
+#
+# Usage - to time code snippets and print results:
+#
+#	timethis($count, '...code...');
+#		
+# prints:
+#	timethis 100:  2 secs ( 0.23 usr  0.10 sys =  0.33 cpu)
+#
+#
+#	timethese($count, {
+#		Name1 => '...code1...',
+#		Name2 => '...code2...',
+#		... });
+# prints:
+#	Benchmark: timing 100 iterations of Name1, Name2...
+#	     Name1:  2 secs ( 0.50 usr  0.00 sys =  0.50 cpu)
+#	     Name2:  1 secs ( 0.48 usr  0.00 sys =  0.48 cpu)
+#
+# The default display style will automatically add child process
+# values if non-zero.
+#
+#
+# Usage - to time sections of your own code:
+#
+#	use Benchmark;
+#	$t0 = new Benchmark;
+#	... your code here ...
+#	$t1 = new Benchmark;
+#	$td = &timediff($t1, $t0);
+#	print "the code took:",timestr($td),"\n";
+#
+#	$t = &timeit($count, '...other code...')
+#	print "$count loops of other code took:",timestr($t),"\n";
+# 
+#
+# Data format:
+#       The data is stored as a list of values from the time and times
+#       functions: ($real, $user, $system, $children_user, $children_system)
+#	in seconds for the whole loop (not divided by the number of rounds).
+#		
+# Internals:
+#	The timing is done using time(3) and times(3).
+#		
+#	Code is executed in the callers package
+#
+#	Enable debugging by:  $Benchmark::debug = 1;
+#
+#	The time of the null loop (a loop with the same
+#	number of rounds but empty loop body) is substracted
+#	from the time of the real loop.
+#
+#	The null loop times are cached, the key being the
+#	number of rounds. The caching can be controlled using
+#	&clearcache($key); &clearallcache;
+#	&disablecache; &enablecache;
+#
+# Caveats:
+#
+#	The real time timing is done using time(2) and
+#	the granularity is therefore only one second.
+#
+#	Short tests may produce negative figures because perl
+#	can appear to take longer to execute the empty loop 
+#	than a short test: try timethis(100,'1');
+#
+#	The system time of the null loop might be slightly
+#	more than the system time of the loop with the actual
+#	code and therefore the difference might end up being < 0
+#
+#	More documentation is needed :-(
+#	Especially for styles and formats.
+#
+# Authors:	Jarkko Hietaniemi <Jarkko.Hietaniemi@hut.fi>
+# 		Tim Bunce <Tim.Bunce@ig.co.uk>
+#
+#
+# Last updated:	Sept 8th 94 by Tim Bunce
+#
+
+use Exporter;
+@ISA=(Exporter);
+@EXPORT=qw(timeit timethis timethese timediff timestr);
+@EXPORT_OK=qw(clearcache clearallcache disablecache enablecache);
+
+&init;
+
+sub init {
+    $debug = 0;
+    $min_count = 4;
+    $min_cpu   = 0.4;
+    $defaultfmt = '5.2f';
+    $defaultstyle = 'auto';
+    # The cache can cause a slight loss of sys time accuracy. If a
+    # user does many tests (>10) with *very* large counts (>10000)
+    # or works on a very slow machine the cache may be useful.
+    &disablecache;
+    &clearallcache;
+}
+
+sub clearcache    { delete $cache{$_[0]}; }
+sub clearallcache { %cache = (); }
+sub enablecache   { $cache = 1; }
+sub disablecache  { $cache = 0; }
+
+
+# --- Functions to process the 'time' data type
+
+sub new { my(@t)=(time, times); print "new=@t\n" if $debug; bless \@t; }
+
+sub cpu_p { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps         ; }
+sub cpu_c { my($r,$pu,$ps,$cu,$cs) = @{$_[0]};         $cu+$cs ; }
+sub cpu_a { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps+$cu+$cs ; }
+sub real  { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $r              ; }
+
+sub timediff{
+    my($a, $b) = @_;
+    my(@r);
+    for($i=0; $i < @$a; ++$i){
+	push(@r, $a->[$i] - $b->[$i]);
+    }
+    bless \@r;
+}
+
+sub timestr{
+    my($tr, $style, $f) = @_;
+    my(@t) = @$tr;
+    warn "bad time value" unless @t==5;
+    my($r, $pu, $ps, $cu, $cs) = @t;
+    my($pt, $ct, $t) = ($tr->cpu_p, $tr->cpu_c, $tr->cpu_a);
+    $f = $defaultfmt unless $f;
+    # format a time in the required style, other formats may be added here
+    $style = $defaultstyle unless $style;
+    $style = ($ct>0) ? 'all' : 'noc' if $style=~/^auto$/;
+    my($s) = "@t $style"; # default for unknown style
+    $s=sprintf("%2d secs (%$f usr %$f sys + %$f cusr %$f csys = %$f cpu)",
+			    @t,$t) if $style =~ /^all$/;
+    $s=sprintf("%2d secs (%$f usr %$f sys = %$f cpu)",
+			    $r,$pu,$ps,$pt) if $style =~ /^noc$/;
+    $s=sprintf("%2d secs (%$f cusr %$f csys = %$f cpu)",
+			    $r,$cu,$cs,$ct) if $style =~ /^nop$/;
+    $s;
+}
+sub timedebug{
+    my($msg, $t) = @_;
+    print STDERR "$msg",timestr($t),"\n" if ($debug);
+}
+
+
+# --- Functions implementing low-level support for timing loops
+
+sub runloop {
+    my($n, $c) = @_;
+    my($t0, $t1, $td); # before, after, difference
+
+    # find package of caller so we can execute code there
+    my ($curpack) = caller(0);
+    my ($i, $pack)= 0;
+    while (($pack) = caller(++$i)) {
+	last if $pack ne $curpack;
+    }
+
+    my $subcode = "sub { package $pack; my(\$_i)=$n; while (\$_i--){$c;} }";
+    my $subref  = eval $subcode;
+    die "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@;
+    print STDERR "runloop $n '$subcode'\n" if ($debug);
+
+    $t0 = &new;
+    &$subref;
+    $t1 = &new;
+    $td = &timediff($t1, $t0);
+
+    timedebug("runloop:",$td);
+    $td;
+}
+
+
+sub timeit {
+    my($n, $code) = @_;
+    my($wn, $wc, $wd);
+
+    printf STDERR "timeit $n $code\n" if $debug;
+
+    if ($cache && exists $cache{$n}){
+	$wn = $cache{$n};
+    }else{
+	$wn = &runloop($n, '');
+	$cache{$n} = $wn;
+    }
+
+    $wc = &runloop($n, $code);
+
+    $wd = timediff($wc, $wn);
+
+    timedebug("timeit: ",$wc);
+    timedebug("      - ",$wn);
+    timedebug("      = ",$wd);
+
+    $wd;
+}
+
+
+# --- Functions implementing high-level time-then-print utilities
+
+sub timethis{
+    my($n, $code, $title, $style) = @_;
+    my($t) = timeit($n, $code);
+    local($|) = 1;
+    $title = "timethis $n" unless $title;
+    $style = "" unless $style;
+    printf("%10s: ", $title);
+    print timestr($t, $style),"\n";
+    # A conservative warning to spot very silly tests.
+    # Don't assume that your benchmark is ok simply because
+    # you don't get this warning!
+    print "            (warning: too few iterations for a reliable count)\n"
+	if (   $n < $min_count
+	    || ($t->real < 1 && $n < 1000)
+	    || $t->cpu_a < $min_cpu);
+    $t;
+}
+
+
+sub timethese{
+    my($n, $alt, $style) = @_;
+    die "usage: timethese(count, { 'Name1'=>'code1', ... }\n"
+		unless ref $alt eq HASH;
+    my(@all);
+    my(@names) = sort keys %$alt;
+    $style = "" unless $style;
+    print "Benchmark: timing $n iterations of ",join(', ',@names),"...\n";
+    foreach(@names){
+	$t = timethis($n, $alt->{$_}, $_, $style);
+	push(@all, $t);
+    }
+    # we could produce a summary from @all here
+    # sum, min, max, avg etc etc
+    @all;
+}
+
+
+1;