utilities/ovs-parse-leaks.in

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