Merge branch 'rb/hashmap-h-compilation-fix'
[git] / t / perf / aggregate.perl
1 #!/usr/bin/perl
2
3 use lib '../../perl/build/lib';
4 use strict;
5 use warnings;
6 use JSON;
7 use Git;
8
9 sub get_times {
10         my $name = shift;
11         open my $fh, "<", $name or return undef;
12         my $line = <$fh>;
13         return undef if not defined $line;
14         close $fh or die "cannot close $name: $!";
15         $line =~ /^(?:(\d+):)?(\d+):(\d+(?:\.\d+)?) (\d+(?:\.\d+)?) (\d+(?:\.\d+)?)$/
16                 or die "bad input line: $line";
17         my $rt = ((defined $1 ? $1 : 0.0)*60+$2)*60+$3;
18         return ($rt, $4, $5);
19 }
20
21 sub format_times {
22         my ($r, $u, $s, $firstr) = @_;
23         if (!defined $r) {
24                 return "<missing>";
25         }
26         my $out = sprintf "%.2f(%.2f+%.2f)", $r, $u, $s;
27         if (defined $firstr) {
28                 if ($firstr > 0) {
29                         $out .= sprintf " %+.1f%%", 100.0*($r-$firstr)/$firstr;
30                 } elsif ($r == 0) {
31                         $out .= " =";
32                 } else {
33                         $out .= " +inf";
34                 }
35         }
36         return $out;
37 }
38
39 my (@dirs, %dirnames, %dirabbrevs, %prefixes, @tests, $codespeed);
40 while (scalar @ARGV) {
41         my $arg = $ARGV[0];
42         my $dir;
43         if ($arg eq "--codespeed") {
44                 $codespeed = 1;
45                 shift @ARGV;
46                 next;
47         }
48         last if -f $arg or $arg eq "--";
49         if (! -d $arg) {
50                 my $rev = Git::command_oneline(qw(rev-parse --verify), $arg);
51                 $dir = "build/".$rev;
52         } else {
53                 $arg =~ s{/*$}{};
54                 $dir = $arg;
55                 $dirabbrevs{$dir} = $dir;
56         }
57         push @dirs, $dir;
58         $dirnames{$dir} = $arg;
59         my $prefix = $dir;
60         $prefix =~ tr/^a-zA-Z0-9/_/c;
61         $prefixes{$dir} = $prefix . '.';
62         shift @ARGV;
63 }
64
65 if (not @dirs) {
66         @dirs = ('.');
67 }
68 $dirnames{'.'} = $dirabbrevs{'.'} = "this tree";
69 $prefixes{'.'} = '';
70
71 shift @ARGV if scalar @ARGV and $ARGV[0] eq "--";
72
73 @tests = @ARGV;
74 if (not @tests) {
75         @tests = glob "p????-*.sh";
76 }
77
78 my $resultsdir = "test-results";
79 my $results_section = "";
80 if (exists $ENV{GIT_PERF_SUBSECTION} and $ENV{GIT_PERF_SUBSECTION} ne "") {
81         $resultsdir .= "/" . $ENV{GIT_PERF_SUBSECTION};
82         $results_section = $ENV{GIT_PERF_SUBSECTION};
83 }
84
85 my @subtests;
86 my %shorttests;
87 for my $t (@tests) {
88         $t =~ s{(?:.*/)?(p(\d+)-[^/]+)\.sh$}{$1} or die "bad test name: $t";
89         my $n = $2;
90         my $fname = "$resultsdir/$t.subtests";
91         open my $fp, "<", $fname or die "cannot open $fname: $!";
92         for (<$fp>) {
93                 chomp;
94                 /^(\d+)$/ or die "malformed subtest line: $_";
95                 push @subtests, "$t.$1";
96                 $shorttests{"$t.$1"} = "$n.$1";
97         }
98         close $fp or die "cannot close $fname: $!";
99 }
100
101 sub read_descr {
102         my $name = shift;
103         open my $fh, "<", $name or return "<error reading description>";
104         binmode $fh, ":utf8" or die "PANIC on binmode: $!";
105         my $line = <$fh>;
106         close $fh or die "cannot close $name";
107         chomp $line;
108         return $line;
109 }
110
111 sub have_duplicate {
112         my %seen;
113         for (@_) {
114                 return 1 if exists $seen{$_};
115                 $seen{$_} = 1;
116         }
117         return 0;
118 }
119 sub have_slash {
120         for (@_) {
121                 return 1 if m{/};
122         }
123         return 0;
124 }
125
126 sub print_default_results {
127         my %descrs;
128         my $descrlen = 4; # "Test"
129         for my $t (@subtests) {
130                 $descrs{$t} = $shorttests{$t}.": ".read_descr("$resultsdir/$t.descr");
131                 $descrlen = length $descrs{$t} if length $descrs{$t}>$descrlen;
132         }
133
134         my %newdirabbrevs = %dirabbrevs;
135         while (!have_duplicate(values %newdirabbrevs)) {
136                 %dirabbrevs = %newdirabbrevs;
137                 last if !have_slash(values %dirabbrevs);
138                 %newdirabbrevs = %dirabbrevs;
139                 for (values %newdirabbrevs) {
140                         s{^[^/]*/}{};
141                 }
142         }
143
144         my %times;
145         my @colwidth = ((0)x@dirs);
146         for my $i (0..$#dirs) {
147                 my $d = $dirs[$i];
148                 my $w = length (exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d});
149                 $colwidth[$i] = $w if $w > $colwidth[$i];
150         }
151         for my $t (@subtests) {
152                 my $firstr;
153                 for my $i (0..$#dirs) {
154                         my $d = $dirs[$i];
155                         $times{$prefixes{$d}.$t} = [get_times("$resultsdir/$prefixes{$d}$t.times")];
156                         my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
157                         my $w = length format_times($r,$u,$s,$firstr);
158                         $colwidth[$i] = $w if $w > $colwidth[$i];
159                         $firstr = $r unless defined $firstr;
160                 }
161         }
162         my $totalwidth = 3*@dirs+$descrlen;
163         $totalwidth += $_ for (@colwidth);
164
165         printf "%-${descrlen}s", "Test";
166         for my $i (0..$#dirs) {
167                 my $d = $dirs[$i];
168                 printf "   %-$colwidth[$i]s", (exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d});
169         }
170         print "\n";
171         print "-"x$totalwidth, "\n";
172         for my $t (@subtests) {
173                 printf "%-${descrlen}s", $descrs{$t};
174                 my $firstr;
175                 for my $i (0..$#dirs) {
176                         my $d = $dirs[$i];
177                         my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
178                         printf "   %-$colwidth[$i]s", format_times($r,$u,$s,$firstr);
179                         $firstr = $r unless defined $firstr;
180                 }
181                 print "\n";
182         }
183 }
184
185 sub print_codespeed_results {
186         my ($results_section) = @_;
187
188         my $project = "Git";
189
190         my $executable = `uname -s -m`;
191         chomp $executable;
192
193         if ($results_section ne "") {
194                 $executable .= ", " . $results_section;
195         }
196
197         my $environment;
198         if (exists $ENV{GIT_PERF_REPO_NAME} and $ENV{GIT_PERF_REPO_NAME} ne "") {
199                 $environment = $ENV{GIT_PERF_REPO_NAME};
200         } elsif (exists $ENV{GIT_TEST_INSTALLED} and $ENV{GIT_TEST_INSTALLED} ne "") {
201                 $environment = $ENV{GIT_TEST_INSTALLED};
202                 $environment =~ s|/bin-wrappers$||;
203         } else {
204                 $environment = `uname -r`;
205                 chomp $environment;
206         }
207
208         my @data;
209
210         for my $t (@subtests) {
211                 for my $d (@dirs) {
212                         my $commitid = $prefixes{$d};
213                         $commitid =~ s/^build_//;
214                         $commitid =~ s/\.$//;
215                         my ($result_value, $u, $s) = get_times("$resultsdir/$prefixes{$d}$t.times");
216
217                         my %vals = (
218                                 "commitid" => $commitid,
219                                 "project" => $project,
220                                 "branch" => $dirnames{$d},
221                                 "executable" => $executable,
222                                 "benchmark" => $shorttests{$t} . " " . read_descr("$resultsdir/$t.descr"),
223                                 "environment" => $environment,
224                                 "result_value" => $result_value,
225                             );
226                         push @data, \%vals;
227                 }
228         }
229
230         print to_json(\@data, {utf8 => 1, pretty => 1}), "\n";
231 }
232
233 binmode STDOUT, ":utf8" or die "PANIC on binmode: $!";
234
235 if ($codespeed) {
236         print_codespeed_results($results_section);
237 } else {
238         print_default_results();
239 }