utilities/ovs-parse-leaks.in

   1 #! @PERL@
   2
   3 # Copyright (c) 2009, 2010 Nicira Networks.
   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: