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