]>
Commit | Line | Data |
---|---|---|
342e9ef2 TR |
1 | #!/usr/bin/perl |
2 | ||
20d2a30f | 3 | use lib '../../perl/build/lib'; |
342e9ef2 TR |
4 | use strict; |
5 | use warnings; | |
05eb1c37 | 6 | use JSON; |
342e9ef2 TR |
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 | ||
05eb1c37 | 39 | my (@dirs, %dirnames, %dirabbrevs, %prefixes, @tests, $codespeed); |
342e9ef2 TR |
40 | while (scalar @ARGV) { |
41 | my $arg = $ARGV[0]; | |
42 | my $dir; | |
05eb1c37 CC |
43 | if ($arg eq "--codespeed") { |
44 | $codespeed = 1; | |
45 | shift @ARGV; | |
46 | next; | |
47 | } | |
342e9ef2 TR |
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 | ||
5d445f34 | 78 | my $resultsdir = "test-results"; |
05eb1c37 | 79 | my $results_section = ""; |
6f5ecad6 | 80 | if (exists $ENV{GIT_PERF_SUBSECTION} and $ENV{GIT_PERF_SUBSECTION} ne "") { |
5d445f34 | 81 | $resultsdir .= "/" . $ENV{GIT_PERF_SUBSECTION}; |
05eb1c37 | 82 | $results_section = $ENV{GIT_PERF_SUBSECTION}; |
5d445f34 CC |
83 | } |
84 | ||
342e9ef2 TR |
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; | |
5d445f34 | 90 | my $fname = "$resultsdir/$t.subtests"; |
342e9ef2 TR |
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>"; | |
db7ed0f2 | 104 | binmode $fh, ":utf8" or die "PANIC on binmode: $!"; |
342e9ef2 TR |
105 | my $line = <$fh>; |
106 | close $fh or die "cannot close $name"; | |
107 | chomp $line; | |
108 | return $line; | |
109 | } | |
110 | ||
342e9ef2 TR |
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 | ||
30ffff6e CC |
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; | |
342e9ef2 | 132 | } |
342e9ef2 | 133 | |
30ffff6e CC |
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); | |
342e9ef2 TR |
146 | for my $i (0..$#dirs) { |
147 | my $d = $dirs[$i]; | |
30ffff6e | 148 | my $w = length (exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d}); |
342e9ef2 | 149 | $colwidth[$i] = $w if $w > $colwidth[$i]; |
342e9ef2 | 150 | } |
30ffff6e CC |
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); | |
db7ed0f2 | 164 | |
30ffff6e | 165 | printf "%-${descrlen}s", "Test"; |
342e9ef2 TR |
166 | for my $i (0..$#dirs) { |
167 | my $d = $dirs[$i]; | |
30ffff6e | 168 | printf " %-$colwidth[$i]s", (exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d}); |
342e9ef2 TR |
169 | } |
170 | print "\n"; | |
30ffff6e CC |
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 | } | |
342e9ef2 | 183 | } |
30ffff6e | 184 | |
05eb1c37 CC |
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 | ||
30ffff6e CC |
233 | binmode STDOUT, ":utf8" or die "PANIC on binmode: $!"; |
234 | ||
05eb1c37 CC |
235 | if ($codespeed) { |
236 | print_codespeed_results($results_section); | |
237 | } else { | |
238 | print_default_results(); | |
239 | } |