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