This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
55c1786d84b2e7d7ae5fa8975a12a712bf743bab
[perl5.git] / Porting / bench.pl
1 #!/usr/bin/perl
2 #
3 # A tool for analysing the performance of the code snippets found in
4 # t/perf/benchmarks or similar
5
6
7 =head1 NAME
8
9 bench.pl - Compare the performance of perl code snippets across multiple
10 perls.
11
12 =head1 SYNOPSIS
13
14     # Basic: run the tests in t/perf/benchmarks against two or
15     # more perls
16
17     bench.pl [options] perlA[=labelA] perlB[=labelB] ...
18
19     # run the tests against the same perl twice, with varying options
20
21     bench.pl [options] perlA=bigint --args='-Mbigint' perlA=plain
22
23     # Run bench on blead, saving results to file; then modify the blead
24     # binary, and benchmark again, comparing against the saved results
25
26     bench.pl [options] --write=blead.time ./perl=blead
27     # ... hack hack hack, updating ./perl ...
28     bench.pl --read=blead.time ./perl=hacked
29
30     # You can also combine --read with --write and new benchmark runs
31
32     bench.pl --read=blead.time --write=last.time -- ./perl=hacked
33
34 =head1 DESCRIPTION
35
36 By default, F<bench.pl> will run code snippets found in
37 F<t/perf/benchmarks> (or similar) under cachegrind, in order to calculate
38 how many instruction reads, data writes, branches, cache misses, etc. that
39 one execution of the snippet uses. Usually it will run them against two or
40 more perl executables and show how much each test has gotten better or
41 worse.
42
43 It is modelled on the F<perlbench> tool, but since it measures instruction
44 reads etc., rather than timings, it is much more precise and reproducible.
45 It is also considerably faster, and is capable of running tests in
46 parallel (with C<-j>). Rather than  displaying a single relative
47 percentage per test/perl combination, it displays values for 13 different
48 measurements, such as instruction reads, conditional branch misses etc.
49
50 There are options to write the raw data to a file, and to read it back.
51 This means that you can view the same run data in different views with
52 different selection and sort options. You can also use this mechanism
53 to save the results of timing one perl, and then read it back while timing
54 a modification, so that you don't have rerun the same tests on the same
55 perl over and over, or have two perl executables built at the same time.
56
57 The optional C<=label> after each perl executable is used in the display
58 output. If you are doing a two step benchmark then you should provide
59 a label for at least the "base" perl. If a label isn't specified, it
60 defaults to the name of the perl executable. Labels must be unique across
61 all current executables, plus any previous ones obtained via --read.
62
63 In its most general form, the specification of a perl executable is:
64
65     path/perl=+mylabel --args='-foo -bar' --args='-baz' \
66                        --env='A=a' --env='B=b'
67
68 This defines how to run the executable F<path/perl>. It has a label,
69 which due to the C<+>, is appended to the binary name to give a label of
70 C<path/perl=+mylabel> (without the C<+>, the label would be just
71 C<mylabel>).
72
73 It can be optionally followed by one or more C<--args> or C<--env>
74 switches, which specify extra command line arguments or environment
75 variables to use when invoking that executable. Each C<--env> switch
76 should be of the form C<--env=VARIABLE=value>. Any C<--arg> values are
77 concatenated to the eventual command line, along with the global
78 C<--perlargs> value if any. The above would cause a system() call looking
79 something like:
80
81     PERL_HASH_SEED=0 A=a B=b valgrind --tool=cachegrind \
82         path/perl -foo -bar -baz ....
83
84 =head1 OPTIONS
85
86 =head2 General options
87
88 =over 4
89
90 =item *
91
92 --action=I<foo>
93
94 What action to perform. The default is  I<grind>, which runs the benchmarks
95 using I<cachegrind> as the back end. The only other action at the moment is
96 I<selftest>, which runs some basic sanity checks and produces TAP output.
97
98 =item *
99
100 --debug
101
102 Enable debugging output.
103
104 =item *
105
106 ---help
107
108 Display basic usage information.
109
110 =item *
111
112 -v
113 --verbose
114
115 Display progress information.
116
117 =back
118
119 =head2 Test selection options
120
121 =over 4
122
123 =item *
124
125 --tests=I<FOO>
126
127 Specify a subset of tests to run (or in the case of C<--read>, to read).
128 It may be either a comma-separated list of test names, or a regular
129 expression. For example
130
131     --tests=expr::assign::scalar_lex,expr::assign::2list_lex
132     --tests=/^expr::/
133
134
135 =back
136
137 =head2 Input options
138
139 =over 4
140
141
142 =item *
143
144 -r I<file>
145 --read=I<file>
146
147 Read in saved data from a previous C<--write> run from the specified file.
148 If C<--tests> is present too, then only tests matching those conditions
149 are read from the file.
150
151 C<--read> may be specified multiple times, in which case the results
152 across all files are aggregated. The list of test names from each file
153 (after filtering by C<--tests>) must be identical across all files.
154
155 This list of tests is used instead of that obtained from the normal
156 benchmark file (or C<--benchfile>) for any benchmarks that are run.
157
158 The perl labels must be unique across all read in test results.
159
160 Requires C<JSON::PP> to be available.
161
162 =back
163
164 =head2 Benchmarking options
165
166 Benchmarks will be run for all perls specified on the command line.
167 These options can be used to modify the benchmarking behavior:
168
169 =over 4
170
171 =item *
172
173 --autolabel
174
175 Generate a unique label for every executable which doesn't have an
176 explicit C<=label>. Works by stripping out common prefixes and suffixes
177 from the executable names, then for any non-unique names, appending
178 C<-0>, C<-1>, etc. text directly surrounding the unique part which look
179 like version numbers (i.e. which match C</[0-9\.]+/>) aren't stripped.
180 For example,
181
182     perl-5.20.0-threaded  perl-5.22.0-threaded  perl-5.24.0-threaded
183
184 stripped to unique parts would be:
185
186     20  22  24
187
188 but is actually only stripped down to:
189
190     5.20.0  5.22.0  5.24.0
191
192 If the final results are plain integers, they are prefixed with "p"
193 to avoid looking like column numbers to switches like C<--norm=2>.
194
195
196 =item *
197
198 --benchfile=I<foo>
199
200 The path of the file which contains the benchmarks (F<t/perf/benchmarks>
201 by default).
202
203 =item *
204
205 --grindargs=I<foo>
206
207 Optional command-line arguments to pass to all cachegrind invocations.
208
209 =item *
210
211 -j I<N>
212 --jobs=I<N>
213
214 Run I<N> jobs in parallel (default 1). This determines how many cachegrind
215 process will run at a time, and should generally be set to the number
216 of CPUs available.
217
218 =item *
219
220 --perlargs=I<foo>
221
222 Optional command-line arguments to pass to every perl executable.  This
223 may optionaly be combined with C<--args> switches following individual
224 perls. For example:
225
226     bench.pl --perlargs='-Ilib -It/lib' .... \
227         perlA --args='-Mstrict' \
228         perlB --args='-Mwarnings'
229
230 would cause the invocations
231
232     perlA -Ilib -It/lib -Mstrict
233     perlB -Ilib -It/lib -Mwarnings
234
235 =back
236
237 =head2 Output options
238
239 Any results accumulated via --read or by running benchmarks can be output
240 in any or all of these three ways:
241
242 =over 4
243
244 =item *
245
246 -w I<file>
247 --write=I<file>
248
249 Save the raw data to the specified file. It can be read back later with
250 C<--read>. If combined with C<--read> then the output file will be
251 the merge of the file read and any additional perls added on the command
252 line.
253
254 Requires C<JSON::PP> to be available.
255
256 =item *
257
258 --bisect=I<field,minval,maxval>
259
260 Exit with a zero status if the named field is in the specified range;
261 exit with 1 otherwise. It will complain if more than one test or perl has
262 been specified. It is intended to be called as part of a bisect run, to
263 determine when something changed.  For example,
264
265     bench.pl -j 8 --tests=foo --bisect=Ir,100,105 --perlargs=-Ilib \
266         ./miniperl
267
268 might be called from bisect to find when the number of instruction reads
269 for test I<foo> falls outside the range 100..105.
270
271 =item *
272
273 --show
274
275 Display the results to stdout in human-readable form.  This is enabled by
276 default, except with --write and --bisect. The following sub-options alter
277 how --show behaves.
278
279 =over 4
280
281 =item *
282
283 --average
284
285 Only display the overall average, rather than the results for each
286 individual test.
287
288 =item *
289
290 --compact=I<perl>
291
292 Display the results for a single perl executable in a compact form.
293 Which perl to display is specified in the same manner as C<--norm>.
294
295 =item *
296
297 --fields=I<a,b,c>
298
299 Display only the specified fields; for example,
300
301     --fields=Ir,Ir_m,Ir_mm
302
303 If only one field is selected, the output is in more compact form.
304
305 =item *
306
307 --norm=I<foo>
308
309 Specify which perl column in the output to treat as the 100% norm.
310 It may be:
311
312 =over
313
314 * a column number (0..N-1),
315
316 * a negative column number (-1..-N) which counts from the right (so -1 is
317 the right-most column),
318
319 * or a perl executable name,
320
321 * or a perl executable label.
322
323 =back
324
325 It defaults to the leftmost column.
326
327 =item *
328
329 --raw
330
331 Display raw data counts rather than percentages in the outputs. This
332 allows you to see the exact number of intruction reads, branch misses etc.
333 for each test/perl combination. It also causes the C<AVERAGE> display
334 per field to be calculated based on the average of each tests's count
335 rather than average of each percentage. This means that tests with very
336 high counts will dominate.
337
338 =item *
339
340 --sort=I<field:perl>
341
342 Order the tests in the output based on the value of I<field> in the
343 column I<perl>. The I<perl> value is as per C<--norm>. For example
344
345     bench.pl --sort=Dw:perl-5.20.0 \
346         perl-5.16.0 perl-5.18.0 perl-5.20.0
347
348 =back
349
350 =back
351
352 =cut
353
354
355
356 use 5.010000;
357 use warnings;
358 use strict;
359 use Getopt::Long qw(:config no_auto_abbrev require_order);
360 use IPC::Open2 ();
361 use IO::Select;
362 use IO::File;
363 use POSIX ":sys_wait_h";
364
365 # The version of the file format used to save data. We refuse to process
366 # the file if the integer component differs.
367
368 my $FORMAT_VERSION = 1.0;
369
370 # The fields we know about
371
372 my %VALID_FIELDS = map { $_ => 1 }
373     qw(Ir Ir_m1 Ir_mm Dr Dr_m1 Dr_mm Dw Dw_m1 Dw_mm COND COND_m IND IND_m);
374
375 sub usage {
376     die <<EOF;
377 Usage: $0 [options] -- perl[=label] ...
378
379 General options:
380
381   --action=foo       What action to perform [default: grind]:
382                         grind      run the code under cachegrind
383                         selftest   perform a selftest; produce TAP output
384   --debug            Enable verbose debugging output.
385   --help             Display this help.
386   -v|--verbose       Display progress information.
387
388
389 Selection:
390
391   --tests=FOO        Select only the specified tests for reading, benchmarking
392                        and display.  FOO may be either a list of tests or
393                        a pattern: 'foo,bar,baz' or '/regex/';
394                        [default: all tests].
395
396 Input:
397
398   -r|--read=file     Read in previously saved data from the specified file.
399                         May be repeated, and be used together with new
400                         benchmarking to create combined results.
401
402 Benchmarking:
403   Benchmarks will be run for any perl specified on the command line.
404   These options can be used to modify the benchmarking behavior:
405
406   --autolabel        generate labels for any executables without one
407   --benchfile=foo    File containing the benchmarks.
408                          [default: t/perf/benchmarks].
409   --grindargs=foo    Optional command-line args to pass to cachegrind.
410   -j|--jobs=N        Run N jobs in parallel [default 1].
411   --perlargs=foo     Optional command-line args to pass to each perl to run.
412
413 Output:
414   Any results accumulated via --read or running benchmarks can be output
415   in any or all of these three ways:
416
417   -w|--write=file    Save the raw data to the specified file (may be read
418                        back later with --read).
419
420   --bisect=f,min,max Exit with a zero status if the named field f is in
421                        the specified min..max range; exit 1 otherwise.
422                        Produces no other output. Only legal if a single
423                        benchmark test has been specified.
424
425   --show             Display the results to stdout in human-readable form.
426                        This is enabled by default, except with --write and
427                        --bisect. The following sub-options alter how
428                        --show behaves.
429
430     --average          Only display average, not individual test results.
431     --compact=perl     Display the results of a single perl in compact form.
432                        Which perl specified like --norm
433     --fields=a,b,c     Display only the specified fields (e.g. Ir,Ir_m,Ir_mm).
434     --norm=perl        Which perl column to treat as 100%; may be a column
435                          number (0..N-1) or a perl executable name or label;
436                          [default: 0].
437     --raw              Display raw data counts rather than percentages.
438     --sort=field:perl  Sort the tests based on the value of 'field' in the
439                        column 'perl'. The perl value is as per --norm.
440
441
442 The command line ends with one or more specified perl executables,
443 which will be searched for in the current \$PATH. Each binary name may
444 have an optional =LABEL appended, which will be used rather than the
445 executable name in output. The labels must be unique across all current
446 executables and previous runs obtained via --read. Each executable may
447 optionally be succeeded by --args= and --env= to specify per-executable
448 arguments and environmenbt variables:
449
450     perl-5.24.0=strict --args='-Mwarnings -Mstrict' --env='FOO=foo' \
451     perl-5.24.0=plain
452 EOF
453 }
454
455 my %OPTS = (
456     action    => 'grind',
457     average   => 0,
458     benchfile => undef,
459     bisect    => undef,
460     compact   => undef,
461     debug     => 0,
462     grindargs => '',
463     fields    => undef,
464     jobs      => 1,
465     norm      => 0,
466     perlargs  => '',
467     raw       => 0,
468     read      => undef,
469     show      => undef,
470     sort      => undef,
471     tests     => undef,
472     verbose   => 0,
473     write     => undef,
474 );
475
476
477 # process command-line args and call top-level action
478
479 {
480     GetOptions(
481         'action=s'    => \$OPTS{action},
482         'average'     => \$OPTS{average},
483         'autolabel'   => \$OPTS{autolabel},
484         'benchfile=s' => \$OPTS{benchfile},
485         'bisect=s'    => \$OPTS{bisect},
486         'compact=s'   => \$OPTS{compact},
487         'debug'       => \$OPTS{debug},
488         'grindargs=s' => \$OPTS{grindargs},
489         'help|h'      => \$OPTS{help},
490         'fields=s'    => \$OPTS{fields},
491         'jobs|j=i'    => \$OPTS{jobs},
492         'norm=s'      => \$OPTS{norm},
493         'perlargs=s'  => \$OPTS{perlargs},
494         'raw'         => \$OPTS{raw},
495         'read|r=s@'   => \$OPTS{read},
496         'show'        => \$OPTS{show},
497         'sort=s'      => \$OPTS{sort},
498         'tests=s'     => \$OPTS{tests},
499         'v|verbose'   => \$OPTS{verbose},
500         'write|w=s'   => \$OPTS{write},
501     ) or die "Use the -h option for usage information.\n";
502
503     usage if $OPTS{help};
504
505
506     if (defined $OPTS{read} or defined $OPTS{write}) {
507         # fail early if it's not present
508         require JSON::PP;
509     }
510
511     if (defined $OPTS{fields}) {
512         my @f = split /,/, $OPTS{fields};
513         for (@f) {
514             die "Error: --fields: unknown field '$_'\n"
515                 unless $VALID_FIELDS{$_};
516         }
517         my %f = map { $_ => 1 } @f;
518         $OPTS{fields} = \%f;
519     }
520
521     my %valid_actions = qw(grind 1 selftest 1);
522     unless ($valid_actions{$OPTS{action}}) {
523         die "Error: unrecognised action '$OPTS{action}'\n"
524           . "must be one of: " . join(', ', sort keys %valid_actions)."\n";
525     }
526
527     if (defined $OPTS{sort}) {
528         my @s = split /:/, $OPTS{sort};
529         if (@s != 2) {
530             die "Error: --sort argument should be of the form field:perl: "
531               . "'$OPTS{sort}'\n";
532         }
533         my ($field, $perl) = @s;
534         die "Error: --sort: unknown field '$field'\n"
535             unless $VALID_FIELDS{$field};
536         # the 'perl' value will be validated later, after we have processed
537         # the perls
538         $OPTS{'sort-field'} = $field;
539         $OPTS{'sort-perl'}  = $perl;
540     }
541
542     # show is the default output action
543     $OPTS{show} = 1 unless $OPTS{write} || $OPTS{bisect};
544
545     if ($OPTS{action} eq 'grind') {
546         do_grind(\@ARGV);
547     }
548     elsif ($OPTS{action} eq 'selftest') {
549         if (@ARGV) {
550             die "Error: no perl executables may be specified with selftest\n"
551         }
552         do_selftest();
553     }
554 }
555 exit 0;
556
557
558 # Given a hash ref keyed by test names, filter it by deleting unwanted
559 # tests, based on $OPTS{tests}.
560
561 sub filter_tests {
562     my ($tests) = @_;
563
564     my $opt = $OPTS{tests};
565     return unless defined $opt;
566
567     my @tests;
568
569     if ($opt =~ m{^/}) {
570         $opt =~ s{^/(.+)/$}{$1}
571             or die "Error: --tests regex must be of the form /.../\n";
572         for (keys %$tests) {
573             delete $tests->{$_} unless /$opt/;
574         }
575     }
576     else {
577         my %t;
578         for (split /,/, $opt) {
579             $t{$_} = 1;
580             next if exists $tests->{$_};
581
582             my $e = "Error: no such test found: '$_'\n";
583             if ($OPTS{verbose}) {
584                 $e .= "Valid test names are:\n";
585                 $e .= "  $_\n" for sort keys %$tests;
586             }
587             else {
588                 $e .= "Re-run with --verbose for a list of valid tests.\n";
589             }
590             die $e;
591         }
592         for (keys %$tests) {
593             delete $tests->{$_} unless exists $t{$_};
594         }
595     }
596     die "Error: no tests to run\n" unless %$tests;
597 }
598
599
600 # Read in the test file, and filter out any tests excluded by $OPTS{tests}
601 # return a hash ref { testname => { test }, ... }
602 # and an array ref of the original test names order,
603
604 sub read_tests_file {
605     my ($file) = @_;
606
607     my $ta;
608     {
609         local @INC = ('.');
610         $ta = do $file;
611     }
612     unless ($ta) {
613         die "Error: can't load '$file': code didn't return a true value\n"
614                 if defined $ta;
615         die "Error: can't parse '$file':\n$@\n" if $@;
616         die "Error: can't read '$file': $!\n";
617     }
618
619     my @orig_order;
620     for (my $i=0; $i < @$ta; $i += 2) {
621         push @orig_order, $ta->[$i];
622     }
623
624     my $t = { @$ta };
625     filter_tests($t);
626     return $t, \@orig_order;
627 }
628
629
630 # Process the perl name/label/column argument of options like --norm and
631 # --sort.  Return the index of the matching perl.
632
633 sub select_a_perl {
634     my ($perl, $perls, $who) = @_;
635     $perls ||= [];
636     my $n = @$perls;
637
638     if ($perl =~ /^-([0-9]+)$/) {
639         my $p = $1;
640         die "Error: $who value $perl outside range -1..-$n\n"
641                                         if $p < 1 || $p > $n;
642         return $n - $p;
643     }
644
645     if ($perl =~ /^[0-9]+$/) {
646         die "Error: $who value $perl outside range 0.." . $#$perls . "\n"
647                                         unless $perl < $n;
648         return $perl;
649     }
650     else {
651         my @perl = grep    $perls->[$_][0] eq $perl
652                         || $perls->[$_][1] eq $perl,
653                         0..$#$perls;
654         unless (@perl) {
655             my $valid = '';
656             for (@$perls) {
657                 $valid .= "    $_->[1]";
658                 $valid .= "  $_->[0]" if $_->[0] ne  $_->[1];
659                 $valid .= "\n";
660             }
661             die "Error: $who: unrecognised perl '$perl'\n"
662               . "Valid perl names are:\n$valid";
663         }
664         die "Error: $who: ambiguous perl '$perl'\n"
665                                         if @perl > 1;
666         return $perl[0];
667     }
668 }
669
670
671 # Validate the list of perl executables on the command line.
672 # The general form is
673 #
674 #      a_perl_exe[=label] [ --args='perl args'] [ --env='FOO=foo' ]
675 #
676 # Return a list of [ exe, label, {env}, 'args' ] tuples
677
678 sub process_executables_list {
679     my ($read_perls, @cmd_line_args) = @_;
680
681     my @results; # returned, each item is [ perlexe, label, {env}, 'args' ]
682     my %seen_from_reads = map { $_->[1] => 1 } @$read_perls;
683     my %seen;
684     my @labels;
685
686     while (@cmd_line_args) {
687         my $item = shift @cmd_line_args;
688
689         if ($item =~ /^--(.*)$/) {
690             my ($switch, $val) = split /=/, $1, 2;
691             die "Error: unrecognised executable switch '--$switch'\n"
692                 unless $switch =~  /^(args|env)$/;
693
694             die "Error: --$switch without a preceding executable name\n"
695                 unless @results;
696
697             unless (defined $val) {
698                 $val = shift @cmd_line_args;
699                 die "Error: --$switch is missing value\n"
700                     unless defined $val;
701             }
702
703             if ($switch eq 'args') {
704                 $results[-1][3] .= " $val";
705             }
706             else {
707                 # --env
708                 $val =~ /^(\w+)=(.*)$/
709                     or die "Error: --env is missing =value\n";
710                 $results[-1][2]{$1} = $2;
711             }
712
713             next;
714         }
715
716         # whatever is left must be the name of an executable
717
718         my ($perl, $label) = split /=/, $item, 2;
719         push @labels, $label;
720         unless ($OPTS{autolabel}) {
721             $label //= $perl;
722             $label = $perl.$label if $label =~ /^\+/;
723         }
724
725         die "Error: duplicate label '$label': "
726                         . "each executable must have a unique label\n"
727             if defined $label && $seen{$label}++;
728
729         die "Error: duplicate label '$label': "
730                         . "seen both in --read file and on command line\n"
731             if defined $label && $seen_from_reads{$label};
732
733         my $r = qx($perl -e 'print qq(ok\n)' 2>&1);
734         die "Error: unable to execute '$perl': $r\n" if $r ne "ok\n";
735
736         push @results, [ $perl, $label,  { }, '' ];
737     }
738
739     # make args '' by default
740     for (@results) {
741         push @$_, '' unless @$_ > 3;
742     }
743
744     if ($OPTS{autolabel}) {
745
746         # create a list of [ 'perl-path', $i ] pairs for all
747         # $results[$i] which don't have a label
748         my @labels;
749         for (0..$#results)  {
750             push @labels, [ $results[$_][0], $_ ]
751                         unless defined $results[$_][1];
752         }
753
754         if (@labels) {
755             # strip off common prefixes
756             my $pre = '';
757           STRIP_PREFIX:
758             while (length $labels[0][0]) {
759                 my $c = substr($labels[0][0], 0, 1);
760                 for my $i (1..$#labels) {
761                     last STRIP_PREFIX if substr($labels[$i][0], 0, 1) ne $c;
762                 }
763                 substr($labels[$_][0], 0, 1)  = '' for 0..$#labels;
764                 $pre .= $c;
765             }
766             # add back any final "version-ish" prefix
767             $pre =~ s/^.*?([0-9\.]*)$/$1/;
768             substr($labels[$_][0], 0, 0) = $pre for 0..$#labels;
769
770             # strip off common suffixes
771             my $post = '';
772           STRIP_SUFFFIX:
773             while (length $labels[0][0]) {
774                 my $c = substr($labels[0][0], -1, 1);
775                 for my $i (1..$#labels) {
776                     last STRIP_SUFFFIX if substr($labels[$i][0], -1, 1) ne $c;
777                 }
778                 chop $labels[$_][0] for 0..$#labels;
779                 $post = "$c$post";
780             }
781             # add back any initial "version-ish" suffix
782             $post =~ s/^([0-9\.]*).*$/$1/;
783             $labels[$_][0] .= $post for 0..$#labels;
784
785             # avoid degenerate empty string for single executable name
786             $labels[0][0] = '0' if @labels == 1 && !length $labels[0][0];
787
788             # if the auto-generated labels are plain integers, prefix
789             # them with 'p' (for perl) to distinguish them from column
790             # indices (otherwise e.g. --norm=2 is ambiguous)
791
792             if ($labels[0][0] =~ /^\d*$/) {
793                 $labels[$_][0] = "p$labels[$_][0]" for 0..$#labels;
794             }
795
796             # now de-duplicate labels
797
798             my (%seen, %index);
799             $seen{$read_perls->[$_][1]}++ for 0..$#$read_perls;
800             $seen{$labels[$_][0]}++ for 0..$#labels;
801
802             for my $i (0..$#labels)  {
803                 my $label = $labels[$i][0];
804                 next unless $seen{$label} > 1;
805                 my $d = length($label) ? '-' : '';
806                 my $n = $index{$label} // 0;
807                 $n++ while exists $seen{"$label$d$n"};
808                 $labels[$i][0] .= "$d$n";
809                 $index{$label} = $n + 1;
810             }
811
812             # finally, store them
813             $results[$_->[1]][1]= $_->[0] for @labels;
814         }
815     }
816
817
818     return @results;
819 }
820
821
822
823 # Return a string containing perl test code wrapped in a loop
824 # that runs $ARGV[0] times
825
826 sub make_perl_prog {
827     my ($test, $desc, $setup, $code) = @_;
828
829     return <<EOF;
830 # $desc
831 package $test;
832 BEGIN { srand(0) }
833 $setup;
834 for my \$__loop__ (1..\$ARGV[0]) {
835     $code;
836 }
837 EOF
838 }
839
840
841 # Parse the output from cachegrind. Return a hash ref.
842 # See do_selftest() for examples of the output format.
843
844 sub parse_cachegrind {
845     my ($output, $id, $perl) = @_;
846
847     my %res;
848
849     my @lines = split /\n/, $output;
850     for (@lines) {
851         unless (s/(==\d+==)|(--\d+--) //) {
852             die "Error: while executing $id:\n"
853               . "unexpected code or cachegrind output:\n$_\n";
854         }
855         if (/I   refs:\s+([\d,]+)/) {
856             $res{Ir} = $1;
857         }
858         elsif (/I1  misses:\s+([\d,]+)/) {
859             $res{Ir_m1} = $1;
860         }
861         elsif (/LLi misses:\s+([\d,]+)/) {
862             $res{Ir_mm} = $1;
863         }
864         elsif (/D   refs:\s+.*?([\d,]+) rd .*?([\d,]+) wr/) {
865             @res{qw(Dr Dw)} = ($1,$2);
866         }
867         elsif (/D1  misses:\s+.*?([\d,]+) rd .*?([\d,]+) wr/) {
868             @res{qw(Dr_m1 Dw_m1)} = ($1,$2);
869         }
870         elsif (/LLd misses:\s+.*?([\d,]+) rd .*?([\d,]+) wr/) {
871             @res{qw(Dr_mm Dw_mm)} = ($1,$2);
872         }
873         elsif (/Branches:\s+.*?([\d,]+) cond .*?([\d,]+) ind/) {
874             @res{qw(COND IND)} = ($1,$2);
875         }
876         elsif (/Mispredicts:\s+.*?([\d,]+) cond .*?([\d,]+) ind/) {
877             @res{qw(COND_m IND_m)} = ($1,$2);
878         }
879     }
880
881     for my $field (keys %VALID_FIELDS) {
882         die "Error: can't parse '$field' field from cachegrind output:\n$output"
883             unless exists $res{$field};
884         $res{$field} =~ s/,//g;
885     }
886
887     return \%res;
888 }
889
890
891 # Handle the 'grind' action
892
893 sub do_grind {
894     my ($cmd_line_args) = @_; # the residue of @ARGV after option processing
895
896     my ($loop_counts, $perls, $results, $tests, $order, @run_perls);
897     my ($bisect_field, $bisect_min, $bisect_max);
898     my ($done_read, $processed, $averages, %seen_labels);
899
900     if (defined $OPTS{bisect}) {
901         ($bisect_field, $bisect_min, $bisect_max) = split /,/, $OPTS{bisect}, 3;
902         die "Error: --bisect option must be of form 'field,integer,integer'\n"
903             unless
904                     defined $bisect_max
905                 and $bisect_min =~ /^[0-9]+$/
906                 and $bisect_max =~ /^[0-9]+$/;
907
908         die "Error: unrecognised field '$bisect_field' in --bisect option\n"
909             unless $VALID_FIELDS{$bisect_field};
910
911         die "Error: --bisect min ($bisect_min) must be <= max ($bisect_max)\n"
912             if $bisect_min > $bisect_max;
913     }
914
915     # Read in previous benchmark results
916
917     foreach my $file (@{$OPTS{read}}) {
918         open my $in, '<:encoding(UTF-8)', $file
919             or die "Error: can't open '$file' for reading: $!\n";
920         my $data = do { local $/; <$in> };
921         close $in;
922
923         my $hash = JSON::PP::decode_json($data);
924         if (int($FORMAT_VERSION) < int($hash->{version})) {
925             die "Error: unsupported version $hash->{version} in file"
926               . " '$file' (too new)\n";
927         }
928         my ($read_loop_counts, $read_perls, $read_results, $read_tests, $read_order) =
929             @$hash{qw(loop_counts perls results tests order)};
930
931         # check file contents for consistency
932         my $k_o = join ';', sort @$read_order;
933         my $k_r = join ';', sort keys %$read_results;
934         my $k_t = join ';', sort keys %$read_tests;
935         die "File '$file' contains no results\n" unless length $k_r;
936         die "File '$file' contains differing test and results names\n"
937             unless $k_r eq $k_t;
938         die "File '$file' contains differing test and sort order names\n"
939             unless $k_o eq $k_t;
940
941         # delete tests not matching --tests= criteria, if any
942         filter_tests($read_results);
943         filter_tests($read_tests);
944
945         for my $perl (@$read_perls) {
946             my $label = $perl->[1];
947             die "Error: duplicate label '$label': seen in file '$file'\n"
948                 if exists $seen_labels{$label};
949             $seen_labels{$label}++;
950         }
951
952         if (!$done_read) {
953             ($loop_counts, $perls, $results, $tests, $order) =
954                 ($read_loop_counts, $read_perls, $read_results, $read_tests, $read_order);
955             $done_read = 1;
956         }
957         else {
958             # merge results across multiple files
959
960             if (   join(';', sort keys %$tests)
961                 ne join(';', sort keys %$read_tests))
962             {
963                 my $err = "Can't merge multiple read files: "
964                         . "they contain differing test sets.\n";
965                 if ($OPTS{verbose}) {
966                     $err .= "Previous tests:\n";
967                     $err .= "  $_\n" for sort keys %$tests;
968                     $err .= "tests from '$file':\n";
969                     $err .= "  $_\n" for sort keys %$read_tests;
970                 }
971                 else {
972                     $err .= "Re-run with --verbose to see the differences.\n";
973                 }
974                 die $err;
975             }
976
977             if ("@$read_loop_counts" ne "@$loop_counts") {
978                 die "Can't merge multiple read files: differing loop counts:\n"
979                 . "  (previous=(@$loop_counts), "
980                 . "'$file'=(@$read_loop_counts))\n";
981             }
982
983             push @$perls, @{$read_perls};
984             foreach my $test (keys %{$read_results}) {
985                 foreach my $label (keys %{$read_results->{$test}}) {
986                     $results->{$test}{$label}= $read_results->{$test}{$label};
987                 }
988             }
989         }
990     }
991     die "Error: --benchfile cannot be used when --read is present\n"
992         if $done_read && defined $OPTS{benchfile};
993
994     # Gather list of perls to benchmark:
995
996     if (@$cmd_line_args) {
997         unless ($done_read) {
998             # How many times to execute the loop for the two trials. The lower
999             # value is intended to do the loop enough times that branch
1000             # prediction has taken hold; the higher loop allows us to see the
1001             # branch misses after that
1002             $loop_counts = [10, 20];
1003
1004             ($tests, $order) =
1005                 read_tests_file($OPTS{benchfile} // 't/perf/benchmarks');
1006         }
1007
1008         @run_perls = process_executables_list($perls, @$cmd_line_args);
1009         push @$perls, @run_perls;
1010     }
1011
1012     # strip @$order to just the actual tests present
1013     $order = [ grep exists $tests->{$_}, @$order ];
1014
1015     # Now we know what perls and tests we have, do extra option processing
1016     # and checking (done before grinding, so time isn't wasted if we die).
1017
1018     if (!$perls or !@$perls) {
1019         die "Error: nothing to do: no perls to run, no data to read.\n";
1020     }
1021     if (@$perls < 2 and $OPTS{show} and !$OPTS{raw}) {
1022         die "Error: need at least 2 perls for comparison.\n"
1023     }
1024
1025     if ($OPTS{bisect}) {
1026         die "Error: exactly one perl executable must be specified for bisect\n"
1027             unless @$perls == 1;
1028         die "Error: only a single test may be specified with --bisect\n"
1029             unless keys %$tests == 1;
1030     }
1031
1032     $OPTS{norm} = select_a_perl($OPTS{norm}, $perls, "--norm");
1033
1034     if (defined $OPTS{'sort-perl'}) {
1035         $OPTS{'sort-perl'} =
1036                 select_a_perl($OPTS{'sort-perl'}, $perls, "--sort");
1037     }
1038
1039     if (defined $OPTS{'compact'}) {
1040         $OPTS{'compact'} =
1041                 select_a_perl($OPTS{'compact'}, $perls, "--compact");
1042     }
1043
1044
1045     # Run the benchmarks; accumulate with any previously read # results.
1046
1047     if (@run_perls) {
1048         $results = grind_run($tests, $order, \@run_perls, $loop_counts, $results);
1049     }
1050
1051
1052     # Handle the 3 forms of output
1053
1054     if (defined $OPTS{write}) {
1055         my $json = JSON::PP::encode_json({
1056                     version      => $FORMAT_VERSION,
1057                     loop_counts  => $loop_counts,
1058                     perls        => $perls,
1059                     results      => $results,
1060                     tests        => $tests,
1061                     order        => $order,
1062                 });
1063
1064         open my $out, '>:encoding(UTF-8)', $OPTS{write}
1065             or die "Error: can't open '$OPTS{write}' for writing: $!\n";
1066         print $out $json or die "Error: writing to file '$OPTS{write}': $!\n";
1067         close $out       or die "Error: closing file '$OPTS{write}': $!\n";
1068     }
1069
1070     if ($OPTS{show} or $OPTS{bisect}) {
1071         # numerically process the raw data
1072         ($processed, $averages) =
1073                     grind_process($results, $perls, $loop_counts);
1074     }
1075
1076     if ($OPTS{show}) {
1077         if (defined $OPTS{compact}) {
1078             grind_print_compact($processed, $averages, $OPTS{compact},
1079                                 $perls, $tests, $order);
1080         }
1081         else {
1082             grind_print($processed, $averages, $perls, $tests, $order);
1083         }
1084     }
1085
1086     if ($OPTS{bisect}) {
1087         # these panics shouldn't happen if the bisect checks above are sound
1088         my @r = values %$results;
1089         die "Panic: expected exactly one test result in bisect\n"
1090                                                         if @r != 1;
1091         @r = values %{$r[0]};
1092         die "Panic: expected exactly one perl result in bisect\n"
1093                                                         if @r != 1;
1094         my $c = $r[0]{$bisect_field};
1095         die "Panic: no result in bisect for field '$bisect_field'\n"
1096                                                         unless defined $c;
1097
1098         print "Bisect: $bisect_field had the value $c\n";
1099
1100         exit 0 if $bisect_min <= $c and $c <= $bisect_max;
1101         exit 1;
1102     }
1103 }
1104
1105
1106 # Run cachegrind for every test/perl combo.
1107 # It may run several processes in parallel when -j is specified.
1108 # Return a hash ref suitable for input to grind_process()
1109
1110 sub grind_run {
1111     my ($tests, $order, $perls, $counts, $results) = @_;
1112
1113     # Build a list of all the jobs to run
1114
1115     my @jobs;
1116
1117     for my $test (grep $tests->{$_}, @$order) {
1118
1119         # Create two test progs: one with an empty loop and one with code.
1120         # Note that the empty loop is actually '{1;}' rather than '{}';
1121         # this causes the loop to have a single nextstate rather than a
1122         # stub op, so more closely matches the active loop; e.g.:
1123         #   {1;}    => nextstate;                       unstack
1124         #   {$x=1;} => nextstate; const; gvsv; sassign; unstack
1125         my @prog = (
1126             make_perl_prog($test, @{$tests->{$test}}{qw(desc setup)}, '1'),
1127             make_perl_prog($test, @{$tests->{$test}}{qw(desc setup code)}),
1128         );
1129
1130         for my $p (@$perls) {
1131             my ($perl, $label, $env, $args) = @$p;
1132
1133             # Run both the empty loop and the active loop
1134             # $counts->[0] and $counts->[1] times.
1135
1136             for my $i (0,1) {
1137                 for my $j (0,1) {
1138                     my $envstr = '';
1139                     if (ref $env) {
1140                         $envstr .= "$_=$env->{$_} " for sort keys %$env;
1141                     }
1142                     my $cmd = "PERL_HASH_SEED=0 $envstr"
1143                             . "valgrind --tool=cachegrind  --branch-sim=yes "
1144                             . "--cachegrind-out-file=/dev/null "
1145                             . "$OPTS{grindargs} "
1146                             . "$perl $OPTS{perlargs} $args - $counts->[$j] 2>&1";
1147                     # for debugging and error messages
1148                     my $id = "$test/$label "
1149                         . ($i ? "active" : "empty") . "/"
1150                         . ($j ? "long"   : "short") . " loop";
1151
1152                     push @jobs, {
1153                         test   => $test,
1154                         perl   => $perl,
1155                         plabel => $label,
1156                         cmd    => $cmd,
1157                         prog   => $prog[$i],
1158                         active => $i,
1159                         loopix => $j,
1160                         id     => $id,
1161                     };
1162                 }
1163             }
1164         }
1165     }
1166
1167     # Execute each cachegrind and store the results in %results.
1168
1169     local $SIG{PIPE} = 'IGNORE';
1170
1171     my $max_jobs = $OPTS{jobs};
1172     my $running  = 0; # count of executing jobs
1173     my %pids;         # map pids to jobs
1174     my %fds;          # map fds  to jobs
1175     my $select = IO::Select->new();
1176
1177     while (@jobs or $running) {
1178
1179         if ($OPTS{debug}) {
1180             printf "Main loop: pending=%d running=%d\n",
1181                 scalar(@jobs), $running;
1182         }
1183
1184         # Start new jobs
1185
1186         while (@jobs && $running < $max_jobs) {
1187             my $job = shift @jobs;
1188             my ($id, $cmd) =@$job{qw(id cmd)};
1189
1190             my ($in, $out, $pid);
1191             warn "Starting $id\n" if $OPTS{verbose};
1192             eval { $pid = IPC::Open2::open2($out, $in, $cmd); 1; }
1193                 or die "Error: while starting cachegrind subprocess"
1194                    ." for $id:\n$@";
1195             $running++;
1196             $pids{$pid}    = $job;
1197             $fds{"$out"}   = $job;
1198             $job->{out_fd} = $out;
1199             $job->{output} = '';
1200             $job->{pid}    = $pid;
1201
1202             $out->blocking(0);
1203             $select->add($out);
1204
1205             if ($OPTS{debug}) {
1206                 print "Started pid $pid for $id\n";
1207             }
1208
1209             # Note:
1210             # In principle we should write to $in in the main select loop,
1211             # since it may block. In reality,
1212             #  a) the code we write to the perl process's stdin is likely
1213             #     to be less than the OS's pipe buffer size;
1214             #  b) by the time the perl process has read in all its stdin,
1215             #     the only output it should have generated is a few lines
1216             #     of cachegrind output preamble.
1217             # If these assumptions change, then perform the following print
1218             # in the select loop instead.
1219
1220             print $in $job->{prog};
1221             close $in;
1222         }
1223
1224         # Get output of running jobs
1225
1226         if ($OPTS{debug}) {
1227             printf "Select: waiting on (%s)\n",
1228                 join ', ', sort { $a <=> $b } map $fds{$_}{pid},
1229                             $select->handles;
1230         }
1231
1232         my @ready = $select->can_read;
1233
1234         if ($OPTS{debug}) {
1235             printf "Select: pids (%s) ready\n",
1236                 join ', ', sort { $a <=> $b } map $fds{$_}{pid}, @ready;
1237         }
1238
1239         unless (@ready) {
1240             die "Panic: select returned no file handles\n";
1241         }
1242
1243         for my $fd (@ready) {
1244             my $j = $fds{"$fd"};
1245             my $r = sysread $fd, $j->{output}, 8192, length($j->{output});
1246             unless (defined $r) {
1247                 die "Panic: Read from process running $j->{id} gave:\n$!";
1248             }
1249             next if $r;
1250
1251             # EOF
1252
1253             if ($OPTS{debug}) {
1254                 print "Got eof for pid $fds{$fd}{pid} ($j->{id})\n";
1255             }
1256
1257             $select->remove($j->{out_fd});
1258             close($j->{out_fd})
1259                 or die "Panic: closing output fh on $j->{id} gave:\n$!\n";
1260             $running--;
1261             delete $fds{"$j->{out_fd}"};
1262             my $output = $j->{output};
1263
1264             if ($OPTS{debug}) {
1265                 my $p = $j->{prog};
1266                 $p =~ s/^/    : /mg;
1267                 my $o = $output;
1268                 $o =~ s/^/    : /mg;
1269
1270                 print "\n$j->{id}/\nCommand: $j->{cmd}\n"
1271                     . "Input:\n$p"
1272                     . "Output\n$o";
1273             }
1274
1275             $results->{$j->{test}}{$j->{plabel}}[$j->{active}][$j->{loopix}]
1276                     = parse_cachegrind($output, $j->{id}, $j->{perl});
1277         }
1278
1279         # Reap finished jobs
1280
1281         while (1) {
1282             my $kid = waitpid(-1, WNOHANG);
1283             my $ret = $?;
1284             last if $kid <= 0;
1285
1286             unless (exists $pids{$kid}) {
1287                 die "Panic: reaped unexpected child $kid";
1288             }
1289             my $j = $pids{$kid};
1290             if ($ret) {
1291                 die sprintf("Error: $j->{id} gave return status 0x%04x\n", $ret)
1292                     . "with the following output\n:$j->{output}\n";
1293             }
1294             delete $pids{$kid};
1295         }
1296     }
1297
1298     return $results;
1299 }
1300
1301
1302
1303
1304 # grind_process(): process the data that has been extracted from
1305 # cachgegrind's output.
1306 #
1307 # $res is of the form ->{benchmark_name}{perl_label}[active][count]{field_name},
1308 # where active is 0 or 1 indicating an empty or active loop,
1309 # count is 0 or 1 indicating a short or long loop. E.g.
1310 #
1311 #    $res->{'expr::assign::scalar_lex'}{perl-5.21.1}[0][10]{Dw_mm}
1312 #
1313 # The $res data structure is modified in-place by this sub.
1314 #
1315 # $perls is [ [ perl-exe, perl-label], .... ].
1316 #
1317 # $counts is [ N, M ] indicating the counts for the short and long loops.
1318 #
1319 #
1320 # return \%output, \%averages, where
1321 #
1322 # $output{benchmark_name}{perl_label}{field_name} = N
1323 # $averages{perl_label}{field_name} = M
1324 #
1325 # where N is the raw count ($OPTS{raw}), or count_perl0/count_perlI otherwise;
1326 # M is the average raw count over all tests ($OPTS{raw}), or
1327 # 1/(sum(count_perlI/count_perl0)/num_tests) otherwise.
1328
1329 sub grind_process {
1330     my ($res, $perls, $counts) = @_;
1331
1332     # Process the four results for each test/perf combo:
1333     # Convert
1334     #    $res->{benchmark_name}{perl_label}[active][count]{field_name} = n
1335     # to
1336     #    $res->{benchmark_name}{perl_label}{field_name} = averaged_n
1337     #
1338     # $r[0][1] - $r[0][0] is the time to do ($counts->[1]-$counts->[0])
1339     #                     empty loops, eliminating startup time
1340     # $r[1][1] - $r[1][0] is the time to do ($counts->[1]-$counts->[0])
1341     #                     active loops, eliminating startup time
1342     # (the two startup times may be different because different code
1343     # is being compiled); the difference of the two results above
1344     # divided by the count difference is the time to execute the
1345     # active code once, eliminating both startup and loop overhead.
1346
1347     for my $tests (values %$res) {
1348         for my $r (values %$tests) {
1349             my $r2;
1350             for (keys %{$r->[0][0]}) {
1351                 my $n = (  ($r->[1][1]{$_} - $r->[1][0]{$_})
1352                          - ($r->[0][1]{$_} - $r->[0][0]{$_})
1353                         ) / ($counts->[1] - $counts->[0]);
1354                 $r2->{$_} = $n;
1355             }
1356             $r = $r2;
1357         }
1358     }
1359
1360     my %totals;
1361     my %counts;
1362     my %data;
1363
1364     my $perl_norm = $perls->[$OPTS{norm}][1]; # the label of the reference perl
1365
1366     for my $test_name (keys %$res) {
1367         my $res1 = $res->{$test_name};
1368         my $res2_norm = $res1->{$perl_norm};
1369         for my $perl (keys %$res1) {
1370             my $res2 = $res1->{$perl};
1371             for my $field (keys %$res2) {
1372                 my ($p, $q) = ($res2_norm->{$field}, $res2->{$field});
1373
1374                 if ($OPTS{raw}) {
1375                     # Avoid annoying '-0.0' displays. Ideally this number
1376                     # should never be negative, but fluctuations in
1377                     # startup etc can theoretically make this happen
1378                     $q = 0 if ($q <= 0 && $q > -0.1);
1379                     $totals{$perl}{$field} += $q;
1380                     $counts{$perl}{$field}++;
1381                     $data{$test_name}{$perl}{$field} = $q;
1382                     next;
1383                 }
1384
1385                 # $p and $q are notionally integer counts, but
1386                 # due to variations in startup etc, it's possible for a
1387                 # count which is supposedly zero to be calculated as a
1388                 # small positive or negative value.
1389                 # In this case, set it to zero. Further below we
1390                 # special-case zeros to avoid division by zero errors etc.
1391
1392                 $p = 0.0 if $p < 0.01;
1393                 $q = 0.0 if $q < 0.01;
1394
1395                 if ($p == 0.0 && $q == 0.0) {
1396                     # Both perls gave a count of zero, so no change:
1397                     # treat as 100%
1398                     $totals{$perl}{$field} += 1;
1399                     $counts{$perl}{$field}++;
1400                     $data{$test_name}{$perl}{$field} = 1;
1401                 }
1402                 elsif ($p == 0.0 || $q == 0.0) {
1403                     # If either count is zero, there were too few events
1404                     # to give a meaningful ratio (and we will end up with
1405                     # division by zero if we try). Mark the result undef,
1406                     # indicating that it shouldn't be displayed; and skip
1407                     # adding to the average
1408                     $data{$test_name}{$perl}{$field} = undef;
1409                 }
1410                 else {
1411                     # For averages, we record q/p rather than p/q.
1412                     # Consider a test where perl_norm took 1000 cycles
1413                     # and perlN took 800 cycles. For the individual
1414                     # results we display p/q, or 1.25; i.e. a quarter
1415                     # quicker. For the averages, we instead sum all
1416                     # the 0.8's, which gives the total cycles required to
1417                     # execute all tests, with all tests given equal
1418                     # weight. Later we reciprocate the final result,
1419                     # i.e. 1/(sum(qi/pi)/n)
1420
1421                     $totals{$perl}{$field} += $q/$p;
1422                     $counts{$perl}{$field}++;
1423                     $data{$test_name}{$perl}{$field} = $p/$q;
1424                 }
1425             }
1426         }
1427     }
1428
1429     # Calculate averages based on %totals and %counts accumulated earlier.
1430
1431     my %averages;
1432     for my $perl (keys %totals) {
1433         my $t = $totals{$perl};
1434         for my $field (keys %$t) {
1435             $averages{$perl}{$field} = $OPTS{raw}
1436                 ? $t->{$field} / $counts{$perl}{$field}
1437                   # reciprocal - see comments above
1438                 : $counts{$perl}{$field} / $t->{$field};
1439         }
1440     }
1441
1442     return \%data, \%averages;
1443 }
1444
1445
1446
1447 # print a standard blurb at the start of the grind display
1448
1449 sub grind_blurb {
1450     my ($perls) = @_;
1451
1452     print <<EOF;
1453 Key:
1454     Ir   Instruction read
1455     Dr   Data read
1456     Dw   Data write
1457     COND conditional branches
1458     IND  indirect branches
1459     _m   branch predict miss
1460     _m1  level 1 cache miss
1461     _mm  last cache (e.g. L3) miss
1462     -    indeterminate percentage (e.g. 1/0)
1463
1464 EOF
1465
1466     if ($OPTS{raw}) {
1467         print "The numbers represent raw counts per loop iteration.\n";
1468     }
1469     else {
1470         print <<EOF;
1471 The numbers represent relative counts per loop iteration, compared to
1472 $perls->[$OPTS{norm}][1] at 100.0%.
1473 Higher is better: for example, using half as many instructions gives 200%,
1474 while using twice as many gives 50%.
1475 EOF
1476     }
1477 }
1478
1479
1480 # return a sorted list of the test names, plus 'AVERAGE'
1481
1482 sub sorted_test_names {
1483     my ($results, $order, $perls) = @_;
1484
1485     my @names;
1486     unless ($OPTS{average}) {
1487         if (defined $OPTS{'sort-field'}) {
1488             my ($field, $perlix) = @OPTS{'sort-field', 'sort-perl'};
1489             my $perl = $perls->[$perlix][1];
1490             @names = sort
1491                 {
1492                         $results->{$a}{$perl}{$field}
1493                     <=> $results->{$b}{$perl}{$field}
1494                 }
1495                 keys %$results;
1496         }
1497         else {
1498             @names = grep $results->{$_}, @$order;
1499         }
1500     }
1501
1502     # No point in displaying average for only one test.
1503     push @names,  'AVERAGE' unless @names == 1;
1504     @names;
1505 }
1506
1507
1508 # format one cell data item
1509
1510 sub grind_format_cell {
1511     my ($val, $width) = @_;
1512     my $s;
1513     if (!defined $val) {
1514         return sprintf "%*s", $width, '-';
1515     }
1516     elsif (abs($val) >= 1_000_000) {
1517         # avoid displaying very large numbers (which might be the
1518         # result of e.g. 1 / 0.000001)
1519         return sprintf "%*s", $width, 'Inf';
1520     }
1521     elsif ($OPTS{raw}) {
1522         return sprintf "%*.1f", $width, $val;
1523     }
1524     else {
1525         return sprintf "%*.2f", $width, $val * 100;
1526     }
1527 }
1528
1529 # grind_print(): display the tabulated results of all the cachegrinds.
1530 #
1531 # Arguments are of the form:
1532 #    $results->{benchmark_name}{perl_label}{field_name} = N
1533 #    $averages->{perl_label}{field_name} = M
1534 #    $perls = [ [ perl-exe, perl-label ], ... ]
1535 #    $tests->{test_name}{desc => ..., ...}
1536 #    $order = [ 'foo::bar1', ... ]  # order to display tests
1537
1538 sub grind_print {
1539     my ($results, $averages, $perls, $tests, $order) = @_;
1540
1541     my @perl_names = map $_->[0], @$perls;
1542     my @perl_labels = map $_->[1], @$perls;
1543     my %perl_labels;
1544     $perl_labels{$_->[0]} = $_->[1] for @$perls;
1545
1546     # Print standard header.
1547     grind_blurb($perls);
1548
1549     my @test_names = sorted_test_names($results, $order, $perls);
1550
1551     my @fields = qw(Ir Dr Dw COND IND
1552                      COND_m IND_m
1553                      Ir_m1 Dr_m1 Dw_m1
1554                      Ir_mm Dr_mm Dw_mm
1555                   );
1556
1557     if ($OPTS{fields}) {
1558         @fields = grep exists $OPTS{fields}{$_}, @fields;
1559     }
1560
1561     # If only a single field is to be displayed, use a more compact
1562     # format with only a single line of output per test.
1563
1564     my $one_field = @fields == 1;
1565
1566     # The width of column 0: this is either field names, or for
1567     # $one_field, test names
1568
1569     my $width0 = 0;
1570     for ($one_field ? @test_names : @fields) {
1571         $width0 = length if length > $width0;
1572     }
1573
1574     # Calculate the widths of the data columns
1575
1576     my @widths = map length, @perl_labels;
1577
1578     for my $test (@test_names) {
1579         my $res = ($test eq 'AVERAGE') ? $averages : $results->{$test};
1580         for my $field (@fields) {
1581             for my $i (0..$#widths) {
1582                 my $l = length grind_format_cell(
1583                                     $res->{$perl_labels[$i]}{$field}, 1);
1584                 $widths[$i] = $l if $l > $widths[$i];
1585             }
1586         }
1587     }
1588
1589     # Print the results for each test
1590
1591     for my $test (0..$#test_names) {
1592         my $test_name = $test_names[$test];
1593         my $doing_ave = ($test_name eq 'AVERAGE');
1594         my $res = $doing_ave ? $averages : $results->{$test_name};
1595
1596         # print per-test header
1597
1598         if ($one_field) {
1599             print "\nResults for field $fields[0]\n\n" if $test == 0;
1600         }
1601         else {
1602             print "\n$test_name";
1603             print "\n$tests->{$test_name}{desc}" unless $doing_ave;
1604             print "\n\n";
1605         }
1606
1607         # Print the perl executable names header.
1608
1609         if (!$one_field || $test == 0) {
1610             for my $i (0,1) {
1611                 print " " x $width0;
1612                 for (0..$#widths) {
1613                     printf " %*s", $widths[$_],
1614                         $i ? ('-' x$widths[$_]) : $perl_labels[$_];
1615                 }
1616                 print "\n";
1617             }
1618         }
1619
1620         my $field_suffix = '';
1621
1622         # print a line of data
1623
1624         for my $field (@fields) {
1625             if ($one_field) {
1626                 printf "%-*s", $width0, $test_name;
1627             }
1628             else {
1629                 # If there are enough fields, print a blank line
1630                 # between groups of fields that have the same suffix
1631                 if (@fields > 4) {
1632                     my $s = '';
1633                     $s = $1 if $field =~ /(_\w+)$/;
1634                     print "\n" if $s ne $field_suffix;
1635                     $field_suffix = $s;
1636                 }
1637                 printf "%*s", $width0, $field;
1638             }
1639
1640             for my $i (0..$#widths) {
1641                 print " ", grind_format_cell($res->{$perl_labels[$i]}{$field},
1642                                             $widths[$i]);
1643             }
1644             print "\n";
1645         }
1646     }
1647 }
1648
1649
1650
1651 # grind_print_compact(): like grind_print(), but display a single perl
1652 # in a compact form. Has an additional arg, $which_perl, which specifies
1653 # which perl to display.
1654 #
1655 # Arguments are of the form:
1656 #    $results->{benchmark_name}{perl_label}{field_name} = N
1657 #    $averages->{perl_label}{field_name} = M
1658 #    $perls = [ [ perl-exe, perl-label ], ... ]
1659 #    $tests->{test_name}{desc => ..., ...}
1660 #    $order = [ 'foo::bar1', ... ]  # order to display tests
1661
1662 sub grind_print_compact {
1663     my ($results, $averages, $which_perl, $perls, $tests, $order) = @_;
1664
1665     # Print standard header.
1666     grind_blurb($perls);
1667
1668     print "\nResults for $perls->[$which_perl][1]\n\n";
1669
1670     my @test_names = sorted_test_names($results, $order, $perls);
1671
1672     # Dump the results for each test.
1673
1674      my @fields = qw( Ir Dr Dw
1675                       COND IND
1676                       COND_m IND_m
1677                       Ir_m1 Dr_m1 Dw_m1
1678                       Ir_mm Dr_mm Dw_mm
1679                     );
1680     if ($OPTS{fields}) {
1681         @fields = grep exists $OPTS{fields}{$_}, @fields;
1682     }
1683
1684     # calculate the the max width of the test names
1685
1686     my $name_width = 0;
1687     for (@test_names) {
1688         $name_width = length if length > $name_width;
1689     }
1690
1691     # Calculate the widths of the data columns
1692
1693     my @widths = map length, @fields;
1694
1695     for my $test (@test_names) {
1696         my $res = ($test eq 'AVERAGE') ? $averages : $results->{$test};
1697         $res = $res->{$perls->[$which_perl][1]};
1698         for my $i (0..$#fields) {
1699             my $l = length grind_format_cell($res->{$fields[$i]}, 1);
1700             $widths[$i] = $l if $l > $widths[$i];
1701         }
1702     }
1703
1704     # Print header
1705
1706     printf " %*s", $widths[$_], $fields[$_] for 0..$#fields;
1707     print "\n";
1708     printf " %*s", $_, ('-' x $_) for @widths;
1709     print "\n";
1710
1711     # Print the results for each test
1712
1713     for my $test_name (@test_names) {
1714         my $doing_ave = ($test_name eq 'AVERAGE');
1715         my $res = $doing_ave ? $averages : $results->{$test_name};
1716         $res = $res->{$perls->[$which_perl][1]};
1717         my $desc = $doing_ave
1718             ? $test_name
1719             : sprintf "%-*s   %s", $name_width, $test_name,
1720                                  $tests->{$test_name}{desc};
1721
1722         for my $i (0..$#fields) {
1723             print " ", grind_format_cell($res->{$fields[$i]}, $widths[$i]);
1724         }
1725         print "  $desc\n";
1726     }
1727 }
1728
1729
1730 # do_selftest(): check that we can parse known cachegrind()
1731 # output formats. If the output of cachegrind changes, add a *new*
1732 # test here; keep the old tests to make sure we continue to parse
1733 # old cachegrinds
1734
1735 sub do_selftest {
1736
1737     my @tests = (
1738         'standard',
1739         <<'EOF',
1740 ==32350== Cachegrind, a cache and branch-prediction profiler
1741 ==32350== Copyright (C) 2002-2013, and GNU GPL'd, by Nicholas Nethercote et al.
1742 ==32350== Using Valgrind-3.9.0 and LibVEX; rerun with -h for copyright info
1743 ==32350== Command: perl5211o /tmp/uiS2gjdqe5 1
1744 ==32350== 
1745 --32350-- warning: L3 cache found, using its data for the LL simulation.
1746 ==32350== 
1747 ==32350== I   refs:      1,124,055
1748 ==32350== I1  misses:        5,573
1749 ==32350== LLi misses:        3,338
1750 ==32350== I1  miss rate:      0.49%
1751 ==32350== LLi miss rate:      0.29%
1752 ==32350== 
1753 ==32350== D   refs:        404,275  (259,191 rd   + 145,084 wr)
1754 ==32350== D1  misses:        9,608  (  6,098 rd   +   3,510 wr)
1755 ==32350== LLd misses:        5,794  (  2,781 rd   +   3,013 wr)
1756 ==32350== D1  miss rate:       2.3% (    2.3%     +     2.4%  )
1757 ==32350== LLd miss rate:       1.4% (    1.0%     +     2.0%  )
1758 ==32350== 
1759 ==32350== LL refs:          15,181  ( 11,671 rd   +   3,510 wr)
1760 ==32350== LL misses:         9,132  (  6,119 rd   +   3,013 wr)
1761 ==32350== LL miss rate:        0.5% (    0.4%     +     2.0%  )
1762 ==32350== 
1763 ==32350== Branches:        202,372  (197,050 cond +   5,322 ind)
1764 ==32350== Mispredicts:      19,153  ( 17,742 cond +   1,411 ind)
1765 ==32350== Mispred rate:        9.4% (    9.0%     +    26.5%   )
1766 EOF
1767         {
1768             COND    =>  197050,
1769             COND_m  =>   17742,
1770             Dr      =>  259191,
1771             Dr_m1   =>    6098,
1772             Dr_mm   =>    2781,
1773             Dw      =>  145084,
1774             Dw_m1   =>    3510,
1775             Dw_mm   =>    3013,
1776             IND     =>    5322,
1777             IND_m   =>    1411,
1778             Ir      => 1124055,
1779             Ir_m1   =>    5573,
1780             Ir_mm   =>    3338,
1781         },
1782     );
1783
1784     for ('./t', '.') {
1785         my $t = "$_/test.pl";
1786         next unless  -f $t;
1787         require $t;
1788     }
1789     plan(@tests / 3 * keys %VALID_FIELDS);
1790
1791     while (@tests) {
1792         my $desc     = shift @tests;
1793         my $output   = shift @tests;
1794         my $expected = shift @tests;
1795         my $p = parse_cachegrind($output);
1796         for (sort keys %VALID_FIELDS) {
1797             is($p->{$_}, $expected->{$_}, "$desc, $_");
1798         }
1799     }
1800 }