This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl5.001 patch.1f
[perl5.git] / lib / Benchmark.pm
CommitLineData
a0d0e21e
LW
1package Benchmark;
2
3# Purpose: benchmark running times of code.
4#
5#
6# Usage - to time code snippets and print results:
7#
8# timethis($count, '...code...');
9#
10# prints:
11# timethis 100: 2 secs ( 0.23 usr 0.10 sys = 0.33 cpu)
12#
13#
14# timethese($count, {
15# Name1 => '...code1...',
16# Name2 => '...code2...',
17# ... });
18# prints:
19# Benchmark: timing 100 iterations of Name1, Name2...
20# Name1: 2 secs ( 0.50 usr 0.00 sys = 0.50 cpu)
21# Name2: 1 secs ( 0.48 usr 0.00 sys = 0.48 cpu)
22#
23# The default display style will automatically add child process
24# values if non-zero.
25#
26#
27# Usage - to time sections of your own code:
28#
29# use Benchmark;
30# $t0 = new Benchmark;
31# ... your code here ...
32# $t1 = new Benchmark;
33# $td = &timediff($t1, $t0);
34# print "the code took:",timestr($td),"\n";
35#
36# $t = &timeit($count, '...other code...')
37# print "$count loops of other code took:",timestr($t),"\n";
38#
39#
40# Data format:
41# The data is stored as a list of values from the time and times
42# functions: ($real, $user, $system, $children_user, $children_system)
43# in seconds for the whole loop (not divided by the number of rounds).
44#
45# Internals:
46# The timing is done using time(3) and times(3).
47#
48# Code is executed in the callers package
49#
50# Enable debugging by: $Benchmark::debug = 1;
51#
52# The time of the null loop (a loop with the same
53# number of rounds but empty loop body) is substracted
54# from the time of the real loop.
55#
56# The null loop times are cached, the key being the
57# number of rounds. The caching can be controlled using
58# &clearcache($key); &clearallcache;
59# &disablecache; &enablecache;
60#
61# Caveats:
62#
63# The real time timing is done using time(2) and
64# the granularity is therefore only one second.
65#
66# Short tests may produce negative figures because perl
67# can appear to take longer to execute the empty loop
68# than a short test: try timethis(100,'1');
69#
70# The system time of the null loop might be slightly
71# more than the system time of the loop with the actual
72# code and therefore the difference might end up being < 0
73#
74# More documentation is needed :-(
75# Especially for styles and formats.
76#
77# Authors: Jarkko Hietaniemi <Jarkko.Hietaniemi@hut.fi>
78# Tim Bunce <Tim.Bunce@ig.co.uk>
79#
80#
81# Last updated: Sept 8th 94 by Tim Bunce
82#
83
84use Exporter;
85@ISA=(Exporter);
86@EXPORT=qw(timeit timethis timethese timediff timestr);
87@EXPORT_OK=qw(clearcache clearallcache disablecache enablecache);
88
89&init;
90
91sub init {
92 $debug = 0;
93 $min_count = 4;
94 $min_cpu = 0.4;
95 $defaultfmt = '5.2f';
96 $defaultstyle = 'auto';
97 # The cache can cause a slight loss of sys time accuracy. If a
98 # user does many tests (>10) with *very* large counts (>10000)
99 # or works on a very slow machine the cache may be useful.
100 &disablecache;
101 &clearallcache;
102}
103
104sub clearcache { delete $cache{$_[0]}; }
105sub clearallcache { %cache = (); }
106sub enablecache { $cache = 1; }
107sub disablecache { $cache = 0; }
108
109
110# --- Functions to process the 'time' data type
111
112sub new { my(@t)=(time, times); print "new=@t\n" if $debug; bless \@t; }
113
114sub cpu_p { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps ; }
115sub cpu_c { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $cu+$cs ; }
116sub cpu_a { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps+$cu+$cs ; }
117sub real { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $r ; }
118
119sub timediff{
120 my($a, $b) = @_;
121 my(@r);
122 for($i=0; $i < @$a; ++$i){
123 push(@r, $a->[$i] - $b->[$i]);
124 }
125 bless \@r;
126}
127
128sub timestr{
129 my($tr, $style, $f) = @_;
130 my(@t) = @$tr;
131 warn "bad time value" unless @t==5;
132 my($r, $pu, $ps, $cu, $cs) = @t;
133 my($pt, $ct, $t) = ($tr->cpu_p, $tr->cpu_c, $tr->cpu_a);
134 $f = $defaultfmt unless $f;
135 # format a time in the required style, other formats may be added here
136 $style = $defaultstyle unless $style;
137 $style = ($ct>0) ? 'all' : 'noc' if $style=~/^auto$/;
138 my($s) = "@t $style"; # default for unknown style
139 $s=sprintf("%2d secs (%$f usr %$f sys + %$f cusr %$f csys = %$f cpu)",
140 @t,$t) if $style =~ /^all$/;
141 $s=sprintf("%2d secs (%$f usr %$f sys = %$f cpu)",
142 $r,$pu,$ps,$pt) if $style =~ /^noc$/;
143 $s=sprintf("%2d secs (%$f cusr %$f csys = %$f cpu)",
144 $r,$cu,$cs,$ct) if $style =~ /^nop$/;
145 $s;
146}
147sub timedebug{
148 my($msg, $t) = @_;
149 print STDERR "$msg",timestr($t),"\n" if ($debug);
150}
151
152
153# --- Functions implementing low-level support for timing loops
154
155sub runloop {
156 my($n, $c) = @_;
157 my($t0, $t1, $td); # before, after, difference
158
159 # find package of caller so we can execute code there
160 my ($curpack) = caller(0);
161 my ($i, $pack)= 0;
162 while (($pack) = caller(++$i)) {
163 last if $pack ne $curpack;
164 }
165
166 my $subcode = "sub { package $pack; my(\$_i)=$n; while (\$_i--){$c;} }";
167 my $subref = eval $subcode;
168 die "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@;
169 print STDERR "runloop $n '$subcode'\n" if ($debug);
170
171 $t0 = &new;
172 &$subref;
173 $t1 = &new;
174 $td = &timediff($t1, $t0);
175
176 timedebug("runloop:",$td);
177 $td;
178}
179
180
181sub timeit {
182 my($n, $code) = @_;
183 my($wn, $wc, $wd);
184
185 printf STDERR "timeit $n $code\n" if $debug;
186
187 if ($cache && exists $cache{$n}){
188 $wn = $cache{$n};
189 }else{
190 $wn = &runloop($n, '');
191 $cache{$n} = $wn;
192 }
193
194 $wc = &runloop($n, $code);
195
196 $wd = timediff($wc, $wn);
197
198 timedebug("timeit: ",$wc);
199 timedebug(" - ",$wn);
200 timedebug(" = ",$wd);
201
202 $wd;
203}
204
205
206# --- Functions implementing high-level time-then-print utilities
207
208sub timethis{
209 my($n, $code, $title, $style) = @_;
210 my($t) = timeit($n, $code);
211 local($|) = 1;
212 $title = "timethis $n" unless $title;
213 $style = "" unless $style;
214 printf("%10s: ", $title);
215 print timestr($t, $style),"\n";
216 # A conservative warning to spot very silly tests.
217 # Don't assume that your benchmark is ok simply because
218 # you don't get this warning!
219 print " (warning: too few iterations for a reliable count)\n"
220 if ( $n < $min_count
221 || ($t->real < 1 && $n < 1000)
222 || $t->cpu_a < $min_cpu);
223 $t;
224}
225
226
227sub timethese{
228 my($n, $alt, $style) = @_;
229 die "usage: timethese(count, { 'Name1'=>'code1', ... }\n"
230 unless ref $alt eq HASH;
231 my(@all);
232 my(@names) = sort keys %$alt;
233 $style = "" unless $style;
234 print "Benchmark: timing $n iterations of ",join(', ',@names),"...\n";
235 foreach(@names){
236 $t = timethis($n, $alt->{$_}, $_, $style);
237 push(@all, $t);
238 }
239 # we could produce a summary from @all here
240 # sum, min, max, avg etc etc
241 @all;
242}
243
244
2451;