~james-page/ubuntu/saucy/openvswitch/1.12-snapshot

« back to all changes in this revision

Viewing changes to utilities/ovs-parse-leaks.in

  • Committer: James Page
  • Date: 2013-08-21 10:16:57 UTC
  • mfrom: (1.1.20)
  • Revision ID: james.page@canonical.com-20130821101657-3o0z0qeiv5zkwlzi
New upstream snapshot

Show diffs side-by-side

added added

removed removed

Lines of Context:
1
 
#! @PERL@
2
 
 
3
 
# Copyright (c) 2009, 2010 Nicira, Inc.
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
 
 
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");
35
 
my ($no_syms) = "symbols will not be translated (use --help for help)";
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: