# run the tests against the same perl twice, with varying options
- bench.pl [options] perlA=bigint --args='-Mbigint' perlA=int
+ bench.pl [options] perlA=bigint --args='-Mbigint' perlA=plain
# Run bench on blead, saving results to file; then modify the blead
# binary, and benchmark again, comparing against the saved results
- bench.pl [options] --write=blead.time -- ./perl=blead
+ bench.pl [options] --write=blead.time ./perl=blead
# ... hack hack hack, updating ./perl ...
- bench.pl --read=blead.time -- ./perl=hacked
+ bench.pl --read=blead.time ./perl=hacked
# You can also combine --read with --write and new benchmark runs
In its most general form, the specification of a perl executable is:
- path/perl=+mylabel --args='-foo -bar' --env='A=a' --env='B=b'
+ path/perl=+mylabel --args='-foo -bar' --args='-baz' \
+ --env='A=a' --env='B=b'
This defines how to run the executable F<path/perl>. It has a label,
which due to the C<+>, is appended to the binary name to give a label of
It can be optionally followed by one or more C<--args> or C<--env>
switches, which specify extra command line arguments or environment
variables to use when invoking that executable. Each C<--env> switch
-should be of the form C<--env=VARABLE=value>. Any C<--arg> values are
-concatenated with a space, along with the global C<--perlargs> value if
-any. The above would cause a system() call looking something like:
+should be of the form C<--env=VARIABLE=value>. Any C<--arg> values are
+concatenated to the eventual command line, along with the global
+C<--perlargs> value if any. The above would cause a system() call looking
+something like:
- PERL_HASH_SEED=0 A=a= B=b valgrind --tool=cachegrind \
- path/perl -foo -bar ....
+ PERL_HASH_SEED=0 A=a B=b valgrind --tool=cachegrind \
+ path/perl -foo -bar -baz ....
=head1 OPTIONS
--debug
-Enable verbose debugging output.
+Enable debugging output.
=item *
=item *
+-v
--verbose
Display progress information.
This list of tests is used instead of that obtained from the normal
benchmark file (or C<--benchfile>) for any benchmarks that are run.
+The perl labels must be unique across all read in test results.
+
Requires C<JSON::PP> to be available.
=back
=item *
---benchfile=I<foo>
-
-The path of the file which contains the benchmarks (F<t/perf/benchmarks>
-by default).
-
-=item *
-
---grindargs=I<foo>
+--autolabel
-Optional command-line arguments to pass to all cachegrind invocations.
-
-This option is appended to those which bench.pl uses for its own
-purposes; so it can be used to override them (see --debug output
-below), and can also be 'abused' to add redirects into the valgrind
-command invocation.
-
-For example, this writes PERL_MEM_LOG activity to foobar.$$, because
-3>foobar.$$ redirects fd 3, then perl under PERL_MEM_LOG writes to fd 3.
-
- $ perl Porting/bench.pl --jobs=2 --verbose --debug \
- --tests=call::sub::amp_empty \
- \
- --grindargs='--cachegrind-out-file=junk.$$ 3>foobar.$$' \
- -- \
- perl5.24.0 perl5.24.0:+memlog:PERL_MEM_LOG=3mst
+Generate a unique label for every executable which doesn't have an
+explicit C<=label>. Works by stripping out common prefixes and suffixes
+from the executable names, then for any non-unique names, appending
+C<-0>, C<-1>, etc. text directly surrounding the unique part which look
+like version numbers (i.e. which match C</[0-9\.]+/>) aren't stripped.
+For example,
-for the +memlog tests, this executes as: (shown via --debug, then prettyfied)
+ perl-5.20.0-threaded perl-5.22.0-threaded perl-5.24.0-threaded
- Command: PERL_HASH_SEED=0 PERL_MEM_LOG=3mst
- valgrind --tool=cachegrind --branch-sim=yes
- --cachegrind-out-file=/dev/null --cachegrind-out-file=junk.$$
- 3>foobar.$$ perl5.24.0 - 10 2>&1
+stripped to unique parts would be:
-The result is that a set of junk.$$ files containing raw cachegrind
-output are written, and foobar.$$ contains the expected memlog output.
+ 20 22 24
-Notes:
+but is actually only stripped down to:
-Theres no obvious utility for those junk.$$ and foobar.$$ files, but
-you can have them anyway.
+ 5.20.0 5.22.0 5.24.0
-The 3 in PERL_MEM_LOG=3mst is needed because the output would
-otherwize go to STDERR, and cause parse_cachegrind() to reject the
-test and die.
+If the final results are plain integers, they are prefixed with "p"
+to avoid looking like column numbers to switches like C<--norm=2>.
-The --grindargs redirect is needed to capture the memlog output;
-without it, the memlog output is written to fd3, around
-parse_cachegrind and effectively into /dev/null
-PERL_MEM_LOG is expensive when used.
+=item *
-call::sub::amp_empty
-&foo function call with no args or body
+--benchfile=I<foo>
- perl5.24.0 perl5.24.0+memlog
- ---------- -----------------
- Ir 394.0 543477.5
- Dr 161.0 146814.1
- Dw 72.0 122304.6
- COND 58.0 66796.4
- IND 5.0 5537.7
+The path of the file which contains the benchmarks (F<t/perf/benchmarks>
+by default).
-COND_m 0.0 6743.1
- IND_m 5.0 1490.2
+=item *
- Ir_m1 0.0 683.7
- Dr_m1 0.0 65.9
- Dw_m1 0.0 8.5
+--grindargs=I<foo>
- Ir_mm 0.0 11.6
- Dr_mm 0.0 10.6
- Dw_mm 0.0 4.7
+Optional command-line arguments to pass to all cachegrind invocations.
=item *
--jobs=I<N>
Run I<N> jobs in parallel (default 1). This determines how many cachegrind
-process will running at a time, and should generally be set to the number
+process will run at a time, and should generally be set to the number
of CPUs available.
=item *
--perlargs=I<foo>
Optional command-line arguments to pass to every perl executable. This
-may optionaly be combined with C<--args>s switches following individual
+may optionaly be combined with C<--args> switches following individual
perls. For example:
bench.pl --perlargs='-Ilib -It/lib' .... \
=head2 Output options
-Any results accumulated via --read or running benchmarks can be output
+Any results accumulated via --read or by running benchmarks can be output
in any or all of these three ways:
=over 4
--bisect=I<field,minval,maxval>
-Run a single test against one perl and exit with a zero status if the
-named field is in the specified range; exit 1 otherwise. It will complain
-if more than one test or perl has been specified. It is intended to be
-called as part of a bisect run, to determine when something changed.
-For example,
+Exit with a zero status if the named field is in the specified range;
+exit with 1 otherwise. It will complain if more than one test or perl has
+been specified. It is intended to be called as part of a bisect run, to
+determine when something changed. For example,
bench.pl -j 8 --tests=foo --bisect=Ir,100,105 --perlargs=-Ilib \
./miniperl
=item *
---compact=<Iperl>
+--compact=I<perl>
Display the results for a single perl executable in a compact form.
Which perl to display is specified in the same manner as C<--norm>.
--norm=I<foo>
Specify which perl column in the output to treat as the 100% norm.
-It may be a column number (0..N-1) or a perl executable name or label.
+It may be:
+
+=over
+
+* a column number (0..N-1),
+
+* a negative column number (-1..-N) which counts from the right (so -1 is
+the right-most column),
+
+* or a perl executable name,
+
+* or a perl executable label.
+
+=back
+
It defaults to the leftmost column.
=item *
selftest perform a selftest; produce TAP output
--debug Enable verbose debugging output.
--help Display this help.
- --verbose Display progress information.
+ -v|--verbose Display progress information.
Selection:
Benchmarks will be run for any perl specified on the command line.
These options can be used to modify the benchmarking behavior:
+ --autolabel generate labels for any executables without one
--benchfile=foo File containing the benchmarks.
[default: t/perf/benchmarks].
--grindargs=foo Optional command-line args to pass to cachegrind.
GetOptions(
'action=s' => \$OPTS{action},
'average' => \$OPTS{average},
+ 'autolabel' => \$OPTS{autolabel},
'benchfile=s' => \$OPTS{benchfile},
'bisect=s' => \$OPTS{bisect},
'compact=s' => \$OPTS{compact},
'show' => \$OPTS{show},
'sort=s' => \$OPTS{sort},
'tests=s' => \$OPTS{tests},
- 'verbose' => \$OPTS{verbose},
+ 'v|verbose' => \$OPTS{verbose},
'write|w=s' => \$OPTS{write},
) or die "Use the -h option for usage information.\n";
else {
my %t;
for (split /,/, $opt) {
- die "Error: no such test found: '$_'\n"
- . ($OPTS{verbose} ? " have: @{[ sort keys %$tests ]}\n" : "")
- unless exists $tests->{$_};
$t{$_} = 1;
+ next if exists $tests->{$_};
+
+ my $e = "Error: no such test found: '$_'\n";
+ if ($OPTS{verbose}) {
+ $e .= "Valid test names are:\n";
+ $e .= " $_\n" for sort keys %$tests;
+ }
+ else {
+ $e .= "Re-run with --verbose for a list of valid tests.\n";
+ }
+ die $e;
}
for (keys %$tests) {
delete $tests->{$_} unless exists $t{$_};
die "Error: can't read '$file': $!\n";
}
+ # validate and process each test
+
+ {
+ my %valid = map { $_ => 1 } qw(desc setup code pre post compile);
+ my @tests = @$ta;
+ if (!@tests || @tests % 2 != 0) {
+ die "Error: '$file' does not contain evenly paired test names and hashes\n";
+ }
+ while (@tests) {
+ my $name = shift @tests;
+ my $hash = shift @tests;
+
+ unless ($name =~ /^[a-zA-Z]\w*(::\w+)*$/) {
+ die "Error: '$file': invalid test name: '$name'\n";
+ }
+
+ for (sort keys %$hash) {
+ die "Error: '$file': invalid key '$_' for test '$name'\n"
+ unless exists $valid{$_};
+ }
+
+ # make description default to the code
+ $hash->{desc} = $hash->{code} unless exists $hash->{desc};
+ }
+ }
+
my @orig_order;
for (my $i=0; $i < @$ta; $i += 2) {
push @orig_order, $ta->[$i];
sub select_a_perl {
my ($perl, $perls, $who) = @_;
- $perls||=[];
- if ($perl =~ /^[0-9]$/) {
+ $perls ||= [];
+ my $n = @$perls;
+
+ if ($perl =~ /^-([0-9]+)$/) {
+ my $p = $1;
+ die "Error: $who value $perl outside range -1..-$n\n"
+ if $p < 1 || $p > $n;
+ return $n - $p;
+ }
+
+ if ($perl =~ /^[0-9]+$/) {
die "Error: $who value $perl outside range 0.." . $#$perls . "\n"
- unless $perl < @$perls;
+ unless $perl < $n;
return $perl;
}
else {
my @perl = grep $perls->[$_][0] eq $perl
|| $perls->[$_][1] eq $perl,
0..$#$perls;
- die "Error: $who: unrecognised perl '$perl'\n"
- unless @perl;
+ unless (@perl) {
+ my $valid = '';
+ for (@$perls) {
+ $valid .= " $_->[1]";
+ $valid .= " $_->[0]" if $_->[0] ne $_->[1];
+ $valid .= "\n";
+ }
+ die "Error: $who: unrecognised perl '$perl'\n"
+ . "Valid perl names are:\n$valid";
+ }
die "Error: $who: ambiguous perl '$perl'\n"
if @perl > 1;
return $perl[0];
my @results; # returned, each item is [ perlexe, label, {env}, 'args' ]
my %seen_from_reads = map { $_->[1] => 1 } @$read_perls;
my %seen;
- my @putargs; # collect not-perls into args per PUT
+ my @labels;
while (@cmd_line_args) {
my $item = shift @cmd_line_args;
# whatever is left must be the name of an executable
my ($perl, $label) = split /=/, $item, 2;
- $label //= $perl;
- $label = $perl.$label if $label =~ /^\+/;
+ push @labels, $label;
+ unless ($OPTS{autolabel}) {
+ $label //= $perl;
+ $label = $perl.$label if $label =~ /^\+/;
+ }
die "Error: duplicate label '$label': "
. "each executable must have a unique label\n"
- if $seen{$label}++;
+ if defined $label && $seen{$label}++;
die "Error: duplicate label '$label': "
. "seen both in --read file and on command line\n"
- if $seen_from_reads{$label};
+ if defined $label && $seen_from_reads{$label};
my $r = qx($perl -e 'print qq(ok\n)' 2>&1);
die "Error: unable to execute '$perl': $r\n" if $r ne "ok\n";
push @$_, '' unless @$_ > 3;
}
+ if ($OPTS{autolabel}) {
+
+ # create a list of [ 'perl-path', $i ] pairs for all
+ # $results[$i] which don't have a label
+ my @labels;
+ for (0..$#results) {
+ push @labels, [ $results[$_][0], $_ ]
+ unless defined $results[$_][1];
+ }
+
+ if (@labels) {
+ # strip off common prefixes
+ my $pre = '';
+ STRIP_PREFIX:
+ while (length $labels[0][0]) {
+ my $c = substr($labels[0][0], 0, 1);
+ for my $i (1..$#labels) {
+ last STRIP_PREFIX if substr($labels[$i][0], 0, 1) ne $c;
+ }
+ substr($labels[$_][0], 0, 1) = '' for 0..$#labels;
+ $pre .= $c;
+ }
+ # add back any final "version-ish" prefix
+ $pre =~ s/^.*?([0-9\.]*)$/$1/;
+ substr($labels[$_][0], 0, 0) = $pre for 0..$#labels;
+
+ # strip off common suffixes
+ my $post = '';
+ STRIP_SUFFFIX:
+ while (length $labels[0][0]) {
+ my $c = substr($labels[0][0], -1, 1);
+ for my $i (1..$#labels) {
+ last STRIP_SUFFFIX if substr($labels[$i][0], -1, 1) ne $c;
+ }
+ chop $labels[$_][0] for 0..$#labels;
+ $post = "$c$post";
+ }
+ # add back any initial "version-ish" suffix
+ $post =~ s/^([0-9\.]*).*$/$1/;
+ $labels[$_][0] .= $post for 0..$#labels;
+
+ # avoid degenerate empty string for single executable name
+ $labels[0][0] = '0' if @labels == 1 && !length $labels[0][0];
+
+ # if the auto-generated labels are plain integers, prefix
+ # them with 'p' (for perl) to distinguish them from column
+ # indices (otherwise e.g. --norm=2 is ambiguous)
+
+ if ($labels[0][0] =~ /^\d*$/) {
+ $labels[$_][0] = "p$labels[$_][0]" for 0..$#labels;
+ }
+
+ # now de-duplicate labels
+
+ my (%seen, %index);
+ $seen{$read_perls->[$_][1]}++ for 0..$#$read_perls;
+ $seen{$labels[$_][0]}++ for 0..$#labels;
+
+ for my $i (0..$#labels) {
+ my $label = $labels[$i][0];
+ next unless $seen{$label} > 1;
+ my $d = length($label) ? '-' : '';
+ my $n = $index{$label} // 0;
+ $n++ while exists $seen{"$label$d$n"};
+ $labels[$i][0] .= "$d$n";
+ $index{$label} = $n + 1;
+ }
+
+ # finally, store them
+ $results[$_->[1]][1]= $_->[0] for @labels;
+ }
+ }
+
+
return @results;
}
-# Return a string containing perl test code wrapped in a loop
-# that runs $ARGV[0] times
+# Return a string containing a perl program which runs the benchmark code
+# $ARGV[0] times. If $body is true, include the main body (setup) in
+# the loop; otherwise create an empty loop with just pre and post.
+# Note that an empty body is handled with '1;' so that a completely empty
+# loop has a single nextstate rather than a stub op, so more closely
+# matches the active loop; e.g.:
+# {1;} => nextstate; unstack
+# {$x=1;} => nextstate; const; gvsv; sassign; unstack
+# Note also that each statement is prefixed with a label; this avoids
+# adjacent nextstate ops being optimised away.
+#
+# A final 1; statement is added so that the code is always in void
+# context.
+#
+# It the compile flag is set for a test, the body of the loop is wrapped in
+# eval 'sub { .... }' to measure compile time rather than execution time
sub make_perl_prog {
- my ($test, $desc, $setup, $code) = @_;
+ my ($name, $test, $body) = @_;
+ my ($desc, $setup, $code, $pre, $post, $compile) =
+ @$test{qw(desc setup code pre post compile)};
+
+ $setup //= '';
+ $pre = defined $pre ? "_PRE_: $pre; " : "";
+ $post = defined $post ? "_POST_: $post; " : "";
+ $code = $body ? $code : "1";
+ $code = "_CODE_: $code; ";
+ my $full = "$pre$code$post _CXT_: 1; ";
+ $full = "eval q{sub { $full }};" if $compile;
return <<EOF;
# $desc
-package $test;
+package $name;
BEGIN { srand(0) }
$setup;
for my \$__loop__ (1..\$ARGV[0]) {
- $code;
+ $full
}
EOF
}
# Handle the 'grind' action
sub do_grind {
- my ($perl_args) = @_; # the residue of @ARGV after option processing
+ my ($cmd_line_args) = @_; # the residue of @ARGV after option processing
my ($loop_counts, $perls, $results, $tests, $order, @run_perls);
my ($bisect_field, $bisect_min, $bisect_max);
# Gather list of perls to benchmark:
- if (@$perl_args) {
+ if (@$cmd_line_args) {
unless ($done_read) {
# How many times to execute the loop for the two trials. The lower
# value is intended to do the loop enough times that branch
read_tests_file($OPTS{benchfile} // 't/perf/benchmarks');
}
- @run_perls = process_executables_list($perls, @$perl_args);
+ @run_perls = process_executables_list($perls, @$cmd_line_args);
push @$perls, @run_perls;
}
die "Panic: no result in bisect for field '$bisect_field'\n"
unless defined $c;
+ print "Bisect: $bisect_field had the value $c\n";
+
exit 0 if $bisect_min <= $c and $c <= $bisect_max;
exit 1;
}
for my $test (grep $tests->{$_}, @$order) {
# Create two test progs: one with an empty loop and one with code.
- # Note that the empty loop is actually '{1;}' rather than '{}';
- # this causes the loop to have a single nextstate rather than a
- # stub op, so more closely matches the active loop; e.g.:
- # {1;} => nextstate; unstack
- # {$x=1;} => nextstate; const; gvsv; sassign; unstack
my @prog = (
- make_perl_prog($test, @{$tests->{$test}}{qw(desc setup)}, '1'),
- make_perl_prog($test, @{$tests->{$test}}{qw(desc setup code)}),
+ make_perl_prog($test, $tests->{$test}, 0),
+ make_perl_prog($test, $tests->{$test}, 1),
);
for my $p (@$perls) {
# grind_process(): process the data that has been extracted from
# cachgegrind's output.
#
-# $res is of the form ->{benchmark_name}{perl_name}[active][count]{field_name},
+# $res is of the form ->{benchmark_name}{perl_label}[active][count]{field_name},
# where active is 0 or 1 indicating an empty or active loop,
# count is 0 or 1 indicating a short or long loop. E.g.
#
#
# return \%output, \%averages, where
#
-# $output{benchmark_name}{perl_name}{field_name} = N
-# $averages{perl_name}{field_name} = M
+# $output{benchmark_name}{perl_label}{field_name} = N
+# $averages{perl_label}{field_name} = M
#
# where N is the raw count ($OPTS{raw}), or count_perl0/count_perlI otherwise;
# M is the average raw count over all tests ($OPTS{raw}), or
# Process the four results for each test/perf combo:
# Convert
- # $res->{benchmark_name}{perl_name}[active][count]{field_name} = n
+ # $res->{benchmark_name}{perl_label}[active][count]{field_name} = n
# to
- # $res->{benchmark_name}{perl_name}{field_name} = averaged_n
+ # $res->{benchmark_name}{perl_label}{field_name} = averaged_n
#
# $r[0][1] - $r[0][0] is the time to do ($counts->[1]-$counts->[0])
# empty loops, eliminating startup time
}
+# format one cell data item
+
+sub grind_format_cell {
+ my ($val, $width) = @_;
+ my $s;
+ if (!defined $val) {
+ return sprintf "%*s", $width, '-';
+ }
+ elsif (abs($val) >= 1_000_000) {
+ # avoid displaying very large numbers (which might be the
+ # result of e.g. 1 / 0.000001)
+ return sprintf "%*s", $width, 'Inf';
+ }
+ elsif ($OPTS{raw}) {
+ return sprintf "%*.1f", $width, $val;
+ }
+ else {
+ return sprintf "%*.2f", $width, $val * 100;
+ }
+}
+
# grind_print(): display the tabulated results of all the cachegrinds.
#
# Arguments are of the form:
-# $results->{benchmark_name}{perl_name}{field_name} = N
-# $averages->{perl_name}{field_name} = M
+# $results->{benchmark_name}{perl_label}{field_name} = N
+# $averages->{perl_label}{field_name} = M
# $perls = [ [ perl-exe, perl-label ], ... ]
# $tests->{test_name}{desc => ..., ...}
+# $order = [ 'foo::bar1', ... ] # order to display tests
sub grind_print {
my ($results, $averages, $perls, $tests, $order) = @_;
my %perl_labels;
$perl_labels{$_->[0]} = $_->[1] for @$perls;
- my $field_label_width = 6;
- # Calculate the width to display for each column.
- my $min_width = $OPTS{raw} ? 8 : 6;
- my @widths = map { length($_) < $min_width ? $min_width : length($_) }
- @perl_labels;
-
# Print standard header.
grind_blurb($perls);
my @test_names = sorted_test_names($results, $order, $perls);
+ my @fields = qw(Ir Dr Dw COND IND
+ COND_m IND_m
+ Ir_m1 Dr_m1 Dw_m1
+ Ir_mm Dr_mm Dw_mm
+ );
+
+ if ($OPTS{fields}) {
+ @fields = grep exists $OPTS{fields}{$_}, @fields;
+ }
+
# If only a single field is to be displayed, use a more compact
# format with only a single line of output per test.
- my $one_field = defined $OPTS{fields} && keys(%{$OPTS{fields}}) == 1;
+ my $one_field = @fields == 1;
- if ($one_field) {
- print "Results for field " . (keys(%{$OPTS{fields}}))[0] . ".\n";
+ # The width of column 0: this is either field names, or for
+ # $one_field, test names
- # The first column will now contain test names rather than
- # field names; Calculate the max width.
+ my $width0 = 0;
+ for ($one_field ? @test_names : @fields) {
+ $width0 = length if length > $width0;
+ }
- $field_label_width = 0;
- for (@test_names) {
- $field_label_width = length if length > $field_label_width;
- }
+ # Calculate the widths of the data columns
- # Print the perl executables header.
+ my @widths = map length, @perl_labels;
- print "\n";
- for my $i (0,1) {
- print " " x $field_label_width;
- for (0..$#widths) {
- printf " %*s", $widths[$_],
- $i ? ('-' x$widths[$_]) : $perl_labels[$_];
+ for my $test (@test_names) {
+ my $res = ($test eq 'AVERAGE') ? $averages : $results->{$test};
+ for my $field (@fields) {
+ for my $i (0..$#widths) {
+ my $l = length grind_format_cell(
+ $res->{$perl_labels[$i]}{$field}, 1);
+ $widths[$i] = $l if $l > $widths[$i];
}
- print "\n";
}
}
- # Dump the results for each test.
+ # Print the results for each test
- for my $test_name (@test_names) {
+ for my $test (0..$#test_names) {
+ my $test_name = $test_names[$test];
my $doing_ave = ($test_name eq 'AVERAGE');
- my $res1 = $doing_ave ? $averages : $results->{$test_name};
+ my $res = $doing_ave ? $averages : $results->{$test_name};
- unless ($one_field) {
+ # print per-test header
+
+ if ($one_field) {
+ print "\nResults for field $fields[0]\n\n" if $test == 0;
+ }
+ else {
print "\n$test_name";
print "\n$tests->{$test_name}{desc}" unless $doing_ave;
print "\n\n";
+ }
- # Print the perl executables header.
+ # Print the perl executable names header.
+
+ if (!$one_field || $test == 0) {
for my $i (0,1) {
- print " " x $field_label_width;
+ print " " x $width0;
for (0..$#widths) {
printf " %*s", $widths[$_],
- $i ? ('-' x$widths[$_]) : $perl_labels[$_];
+ $i ? ('-' x$widths[$_]) : $perl_labels[$_];
}
print "\n";
}
}
- for my $field (qw(Ir Dr Dw COND IND
- N
- COND_m IND_m
- N
- Ir_m1 Dr_m1 Dw_m1
- N
- Ir_mm Dr_mm Dw_mm
- ))
- {
- next if $OPTS{fields} and ! exists $OPTS{fields}{$field};
+ my $field_suffix = '';
- if ($field eq 'N') {
- print "\n";
- next;
- }
+ # print a line of data
+ for my $field (@fields) {
if ($one_field) {
- printf "%-*s", $field_label_width, $test_name;
+ printf "%-*s", $width0, $test_name;
}
else {
- printf "%*s", $field_label_width, $field;
+ # If there are enough fields, print a blank line
+ # between groups of fields that have the same suffix
+ if (@fields > 4) {
+ my $s = '';
+ $s = $1 if $field =~ /(_\w+)$/;
+ print "\n" if $s ne $field_suffix;
+ $field_suffix = $s;
+ }
+ printf "%*s", $width0, $field;
}
for my $i (0..$#widths) {
- my $res2 = $res1->{$perl_labels[$i]};
- my $p = $res2->{$field};
- if (!defined $p) {
- printf " %*s", $widths[$i], '-';
- }
- elsif ($OPTS{raw}) {
- printf " %*.1f", $widths[$i], $p;
- }
- else {
- printf " %*.2f", $widths[$i], $p * 100;
- }
+ print " ", grind_format_cell($res->{$perl_labels[$i]}{$field},
+ $widths[$i]);
}
print "\n";
}
# which perl to display.
#
# Arguments are of the form:
-# $results->{benchmark_name}{perl_name}{field_name} = N
-# $averages->{perl_name}{field_name} = M
+# $results->{benchmark_name}{perl_label}{field_name} = N
+# $averages->{perl_label}{field_name} = M
# $perls = [ [ perl-exe, perl-label ], ... ]
# $tests->{test_name}{desc => ..., ...}
+# $order = [ 'foo::bar1', ... ] # order to display tests
sub grind_print_compact {
my ($results, $averages, $which_perl, $perls, $tests, $order) = @_;
-
- # the width to display for each column.
- my $width = $OPTS{raw} ? 7 : 6;
-
# Print standard header.
grind_blurb($perls);
@fields = grep exists $OPTS{fields}{$_}, @fields;
}
- printf " %*s", $width, $_ for @fields;
+ # calculate the the max width of the test names
+
+ my $name_width = 0;
+ for (@test_names) {
+ $name_width = length if length > $name_width;
+ }
+
+ # Calculate the widths of the data columns
+
+ my @widths = map length, @fields;
+
+ for my $test (@test_names) {
+ my $res = ($test eq 'AVERAGE') ? $averages : $results->{$test};
+ $res = $res->{$perls->[$which_perl][1]};
+ for my $i (0..$#fields) {
+ my $l = length grind_format_cell($res->{$fields[$i]}, 1);
+ $widths[$i] = $l if $l > $widths[$i];
+ }
+ }
+
+ # Print header
+
+ printf " %*s", $widths[$_], $fields[$_] for 0..$#fields;
print "\n";
- printf " %*s", $width, '------' for @fields;
+ printf " %*s", $_, ('-' x $_) for @widths;
print "\n";
+ # Print the results for each test
+
for my $test_name (@test_names) {
my $doing_ave = ($test_name eq 'AVERAGE');
my $res = $doing_ave ? $averages : $results->{$test_name};
$res = $res->{$perls->[$which_perl][1]};
+ my $desc = $doing_ave
+ ? $test_name
+ : sprintf "%-*s %s", $name_width, $test_name,
+ $tests->{$test_name}{desc};
- for my $field (@fields) {
- my $p = $res->{$field};
- if (!defined $p) {
- printf " %*s", $width, '-';
- }
- elsif ($OPTS{raw}) {
- printf " %*.1f", $width, $p;
- }
- else {
- printf " %*.2f", $width, $p * 100;
- }
-
+ for my $i (0..$#fields) {
+ print " ", grind_format_cell($res->{$fields[$i]}, $widths[$i]);
}
-
- print " $test_name\n";
+ print " $desc\n";
}
}
https://perl5.git.perl.org / perl5.git / blobdiff