]>
Commit | Line | Data |
---|---|---|
064af421 BP |
1 | #! @PERL@ |
2 | ||
265fcdc7 | 3 | # Copyright (c) 2009, 2010 Nicira Networks. |
a14bc59f BP |
4 | # |
5 | # Licensed under the Apache License, Version 2.0 (the "License"); | |
6 | # you may not use this file except in compliance with the License. | |
7 | # You may obtain a copy of the License at: | |
8 | # | |
9 | # http://www.apache.org/licenses/LICENSE-2.0 | |
10 | # | |
11 | # Unless required by applicable law or agreed to in writing, software | |
12 | # distributed under the License is distributed on an "AS IS" BASIS, | |
13 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. | |
14 | # See the License for the specific language governing permissions and | |
15 | # limitations under the License. | |
16 | ||
064af421 BP |
17 | use strict; |
18 | use warnings; | |
19 | ||
20 | if (grep($_ eq '--help', @ARGV)) { | |
21 | print <<EOF; | |
22 | $0, for parsing leak checker logs | |
23 | usage: $0 [BINARY] < LOG | |
24 | where LOG is a file produced by an Open vSwitch program's --check-leaks option | |
25 | and BINARY is the binary that wrote LOG. | |
26 | EOF | |
27 | exit 0; | |
28 | } | |
29 | ||
30 | die "$0: zero or one arguments required; use --help for help\n" if @ARGV > 1; | |
31 | die "$0: $ARGV[0] does not exist" if @ARGV > 0 && ! -e $ARGV[0]; | |
32 | ||
33 | our ($binary); | |
34 | our ($a2l) = search_path("addr2line"); | |
265fcdc7 | 35 | my ($no_syms) = "symbols will not be translated (use --help for help)"; |
064af421 BP |
36 | if (!@ARGV) { |
37 | print "no binary specified; $no_syms\n"; | |
38 | } elsif (! -e $ARGV[0]) { | |
39 | print "$ARGV[0] does not exist; $no_syms"; | |
40 | } elsif (!defined($a2l)) { | |
41 | print "addr2line not found in PATH; $no_syms"; | |
42 | } else { | |
43 | $binary = $ARGV[0]; | |
44 | } | |
45 | ||
46 | our ($objdump) = search_path("objdump"); | |
47 | print "objdump not found; dynamic library symbols will not be translated\n" | |
48 | if !defined($objdump); | |
49 | ||
50 | our %blocks; | |
51 | our @segments; | |
52 | while (<STDIN>) { | |
53 | my $ptr = "((?:0x)?[0-9a-fA-F]+|\\(nil\\))"; | |
54 | my $callers = ":((?: $ptr)+)"; | |
55 | if (/^malloc\((\d+)\) -> $ptr$callers$/) { | |
56 | allocated($., $2, $1, $3); | |
57 | } elsif (/^claim\($ptr\)$callers$/) { | |
58 | claimed($., $1, $2); | |
59 | } elsif (/realloc\($ptr, (\d+)\) -> $ptr$callers$/) { | |
60 | my ($callers) = $4; | |
61 | freed($., $1, $callers); | |
62 | allocated($., $3, $2, $callers); | |
63 | } elsif (/^free\($ptr\)$callers$/) { | |
64 | freed($., $1, $2); | |
65 | } elsif (/^segment: $ptr-$ptr $ptr [-r][-w][-x][sp] (.*)/) { | |
66 | add_segment(hex($1), hex($2), hex($3), $4); | |
67 | } else { | |
68 | print "stdin:$.: syntax error\n"; | |
69 | } | |
70 | } | |
71 | if (%blocks) { | |
72 | my $n_blocks = scalar(keys(%blocks)); | |
73 | my $n_bytes = 0; | |
74 | $n_bytes += $_->{SIZE} foreach values(%blocks); | |
75 | print "$n_bytes bytes in $n_blocks blocks not freed at end of run\n"; | |
76 | my %blocks_by_callers; | |
77 | foreach my $block (values(%blocks)) { | |
78 | my ($trimmed_callers) = trim_callers($block->{CALLERS}); | |
79 | push (@{$blocks_by_callers{$trimmed_callers}}, $block); | |
80 | } | |
81 | foreach my $callers (sort {@{$b} <=> @{$a}} (values(%blocks_by_callers))) { | |
82 | $n_blocks = scalar(@{$callers}); | |
83 | $n_bytes = 0; | |
84 | $n_bytes += $_->{SIZE} foreach @{$callers}; | |
85 | print "$n_bytes bytes in these $n_blocks blocks were not freed:\n"; | |
86 | my $i = 0; | |
87 | my $max = 5; | |
88 | foreach my $block (sort {$a->{LINE} <=> $b->{LINE}} (@{$callers})) { | |
89 | printf "\t%d-byte block at 0x%08x allocated on stdin:%d\n", | |
90 | $block->{SIZE}, $block->{BASE}, $block->{LINE}; | |
91 | last if $i++ > $max; | |
92 | } | |
93 | print "\t...and ", $n_blocks - $max, " others...\n" | |
94 | if $n_blocks > $max; | |
95 | print "The blocks listed above were allocated by:\n"; | |
96 | print_callers("\t", ${$callers}[0]->{CALLERS}); | |
97 | } | |
98 | } | |
99 | sub interp_pointer { | |
100 | my ($s_ptr) = @_; | |
101 | return $s_ptr eq '(nil)' ? 0 : hex($s_ptr); | |
102 | } | |
103 | ||
104 | sub allocated { | |
105 | my ($line, $s_base, $size, $callers) = @_; | |
106 | my ($base) = interp_pointer($s_base); | |
107 | return if !$base; | |
108 | my ($info) = {LINE => $line, | |
109 | BASE => $base, | |
110 | SIZE => $size, | |
111 | CALLERS => $callers}; | |
112 | if (exists($blocks{$base})) { | |
113 | print "In-use address returned by allocator:\n"; | |
114 | print "\tInitial allocation:\n"; | |
115 | print_block("\t\t", $blocks{$base}); | |
116 | print "\tNew allocation:\n"; | |
117 | print_block("\t\t", $info); | |
118 | } | |
119 | $blocks{$base} = $info; | |
120 | } | |
121 | ||
122 | sub claimed { | |
123 | my ($line, $s_base, $callers) = @_; | |
124 | my ($base) = interp_pointer($s_base); | |
125 | return if !$base; | |
126 | if (exists($blocks{$base})) { | |
127 | $blocks{$base}{LINE} = $line; | |
128 | $blocks{$base}{CALLERS} = $callers; | |
129 | } else { | |
130 | printf "Claim asserted on not-in-use block 0x%08x by:\n", $base; | |
131 | print_callers('', $callers); | |
132 | } | |
133 | } | |
134 | ||
135 | sub freed { | |
136 | my ($line, $s_base, $callers) = @_; | |
137 | my ($base) = interp_pointer($s_base); | |
138 | return if !$base; | |
139 | ||
140 | if (!delete($blocks{$base})) { | |
141 | printf "Bad free of not-allocated address 0x%08x on stdin:%d by:\n", $base, $line; | |
142 | print_callers('', $callers); | |
143 | } | |
144 | } | |
145 | ||
146 | sub print_block { | |
147 | my ($prefix, $info) = @_; | |
148 | printf '%s%d-byte block at 0x%08x allocated on stdin:%d by:' . "\n", | |
149 | $prefix, $info->{SIZE}, $info->{BASE}, $info->{LINE}; | |
150 | print_callers($prefix, $info->{CALLERS}); | |
151 | } | |
152 | ||
153 | sub print_callers { | |
154 | my ($prefix, $callers) = @_; | |
155 | foreach my $pc (split(' ', $callers)) { | |
156 | print "$prefix\t", lookup_pc($pc), "\n"; | |
157 | } | |
158 | } | |
159 | ||
160 | our (%cache); | |
161 | sub lookup_pc { | |
162 | my ($s_pc) = @_; | |
163 | if (defined($binary)) { | |
164 | my ($pc) = hex($s_pc); | |
165 | my ($output) = "$s_pc: "; | |
166 | if (!exists($cache{$pc})) { | |
167 | open(A2L, "$a2l -fe $binary --demangle $s_pc|"); | |
168 | chomp(my $function = <A2L>); | |
169 | chomp(my $line = <A2L>); | |
170 | close(A2L); | |
171 | if ($function eq '??') { | |
172 | ($function, $line) = lookup_pc_by_segment($pc); | |
173 | } | |
174 | $line =~ s/^(\.\.\/)*//; | |
175 | $line = "..." . substr($line, -25) if length($line) > 28; | |
176 | $cache{$pc} = "$s_pc: $function ($line)"; | |
177 | } | |
178 | return $cache{$pc}; | |
179 | } else { | |
180 | return "$s_pc"; | |
181 | } | |
182 | } | |
183 | ||
184 | sub trim_callers { | |
185 | my ($in) = @_; | |
186 | my (@out); | |
187 | foreach my $pc (split(' ', $in)) { | |
188 | my $xlated = lookup_pc($pc); | |
189 | if ($xlated =~ /\?\?/) { | |
190 | push(@out, "...") if !@out || $out[$#out] ne '...'; | |
191 | } else { | |
192 | push(@out, $pc); | |
193 | } | |
194 | } | |
195 | return join(' ', @out); | |
196 | } | |
197 | ||
198 | sub search_path { | |
199 | my ($target) = @_; | |
200 | for my $dir (split (':', $ENV{PATH})) { | |
201 | my ($file) = "$dir/$target"; | |
202 | return $file if -e $file; | |
203 | } | |
204 | return undef; | |
205 | } | |
206 | ||
207 | sub add_segment { | |
208 | my ($vm_start, $vm_end, $vm_pgoff, $file) = @_; | |
209 | for (my $i = 0; $i <= $#segments; $i++) { | |
210 | my ($s) = $segments[$i]; | |
211 | next if $vm_end <= $s->{START} || $vm_start >= $s->{END}; | |
212 | if ($vm_start <= $s->{START} && $vm_end >= $s->{END}) { | |
213 | splice(@segments, $i, 1); | |
214 | --$i; | |
215 | } else { | |
216 | $s->{START} = $vm_end if $vm_end > $s->{START}; | |
217 | $s->{END} = $vm_start if $vm_start <= $s->{END}; | |
218 | } | |
219 | } | |
220 | push(@segments, {START => $vm_start, | |
221 | END => $vm_end, | |
222 | PGOFF => $vm_pgoff, | |
223 | FILE => $file}); | |
224 | @segments = sort { $a->{START} <=> $b->{START} } @segments; | |
225 | } | |
226 | ||
227 | sub binary_search { | |
228 | my ($array, $value) = @_; | |
229 | my $l = 0; | |
230 | my $r = $#{$array}; | |
231 | while ($l <= $r) { | |
232 | my $m = int(($l + $r) / 2); | |
233 | my $e = $array->[$m]; | |
234 | if ($value < $e->{START}) { | |
235 | $r = $m - 1; | |
236 | } elsif ($value >= $e->{END}) { | |
237 | $l = $m + 1; | |
238 | } else { | |
239 | return $e; | |
240 | } | |
241 | } | |
242 | return undef; | |
243 | } | |
244 | ||
245 | sub read_sections { | |
246 | my ($file) = @_; | |
247 | my (@sections); | |
248 | open(OBJDUMP, "$objdump -h $file|"); | |
249 | while (<OBJDUMP>) { | |
250 | my $ptr = "([0-9a-fA-F]+)"; | |
251 | my ($name, $size, $vma, $lma, $file_off) | |
252 | = /^\s*\d+\s+(\S+)\s+$ptr\s+$ptr\s+$ptr\s+$ptr/ | |
253 | or next; | |
254 | push(@sections, {START => hex($file_off), | |
255 | END => hex($file_off) + hex($size), | |
256 | NAME => $name}); | |
257 | } | |
258 | close(OBJDUMP); | |
259 | return [sort { $a->{START} <=> $b->{START} } @sections ]; | |
260 | } | |
261 | ||
262 | our %file_to_sections; | |
263 | sub segment_to_section { | |
264 | my ($file, $file_offset) = @_; | |
265 | if (!defined($file_to_sections{$file})) { | |
266 | $file_to_sections{$file} = read_sections($file); | |
267 | } | |
268 | return binary_search($file_to_sections{$file}, $file_offset); | |
269 | } | |
270 | ||
271 | sub address_to_segment { | |
272 | my ($pc) = @_; | |
273 | return binary_search(\@segments, $pc); | |
274 | } | |
275 | ||
276 | sub lookup_pc_by_segment { | |
277 | return ('??', 0) if !defined($objdump); | |
278 | ||
279 | my ($pc) = @_; | |
280 | my ($segment) = address_to_segment($pc); | |
281 | return ('??', 0) if !defined($segment) || $segment->{FILE} eq ''; | |
282 | ||
283 | my ($file_offset) = $pc - $segment->{START} + $segment->{PGOFF}; | |
284 | my ($section) = segment_to_section($segment->{FILE}, $file_offset); | |
285 | return ('??', 0) if !defined($section); | |
286 | ||
287 | my ($section_offset) = $file_offset - $section->{START}; | |
288 | open(A2L, sprintf("%s -fe %s --demangle --section=$section->{NAME} 0x%x|", | |
289 | $a2l, $segment->{FILE}, $section_offset)); | |
290 | chomp(my $function = <A2L>); | |
291 | chomp(my $line = <A2L>); | |
292 | close(A2L); | |
293 | ||
294 | return ($function, $line); | |
295 | } | |
296 | ||
297 | # Local Variables: | |
298 | # mode: perl | |
299 | # End: |