1#!/usr/bin/perl
2
3use lib '../../perl/build/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, $codespeed);
40while (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
65if (not @dirs) {
66 @dirs = ('.');
67}
68$dirnames{'.'} = $dirabbrevs{'.'} = "this tree";
69$prefixes{'.'} = '';
70
71shift @ARGV if scalar @ARGV and $ARGV[0] eq "--";
72
73@tests = @ARGV;
74if (not @tests) {
75 @tests = glob "p????-*.sh";
76}
77
78my $resultsdir = "test-results";
79my $results_section = "";
80if (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
85my @subtests;
86my %shorttests;
87for 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
101sub 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
111sub have_duplicate {
112 my %seen;
113 for (@_) {
114 return 1 if exists $seen{$_};
115 $seen{$_} = 1;
116 }
117 return 0;
118}
119sub have_slash {
120 for (@_) {
121 return 1 if m{/};
122 }
123 return 0;
124}
125
126sub 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
185sub 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
233binmode STDOUT, ":utf8" or die "PANIC on binmode: $!";
234
235if ($codespeed) {
236 print_codespeed_results($results_section);
237} else {
238 print_default_results();
239}