#! @PERL@

# Copyright (c) 2009, 2010 Nicira Networks.
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at:
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.

use strict;
use warnings;

if (grep($_ eq '--help', @ARGV)) {
    print <<EOF;
$0, for parsing leak checker logs
usage: $0 [BINARY] < LOG
where LOG is a file produced by an Open vSwitch program's --check-leaks option
  and BINARY is the binary that wrote LOG.
EOF
    exit 0;
}

die "$0: zero or one arguments required; use --help for help\n" if @ARGV > 1;
die "$0: $ARGV[0] does not exist" if @ARGV > 0 && ! -e $ARGV[0];

our ($binary);
our ($a2l) = search_path("addr2line");
my ($no_syms) = "symbols will not be translated (use --help for help)";
if (!@ARGV) {
    print "no binary specified; $no_syms\n";
} elsif (! -e $ARGV[0]) {
    print "$ARGV[0] does not exist; $no_syms";
} elsif (!defined($a2l)) {
    print "addr2line not found in PATH; $no_syms";
} else {
    $binary = $ARGV[0];
}

our ($objdump) = search_path("objdump");
print "objdump not found; dynamic library symbols will not be translated\n"
  if !defined($objdump);

our %blocks;
our @segments;
while (<STDIN>) {
    my $ptr = "((?:0x)?[0-9a-fA-F]+|\\(nil\\))";
    my $callers = ":((?: $ptr)+)";
    if (/^malloc\((\d+)\) -> $ptr$callers$/) {
        allocated($., $2, $1, $3);
    } elsif (/^claim\($ptr\)$callers$/) {
        claimed($., $1, $2);
    } elsif (/realloc\($ptr, (\d+)\) -> $ptr$callers$/) {
        my ($callers) = $4;
        freed($., $1, $callers);
        allocated($., $3, $2, $callers);
    } elsif (/^free\($ptr\)$callers$/) {
        freed($., $1, $2);
    } elsif (/^segment: $ptr-$ptr $ptr [-r][-w][-x][sp] (.*)/) {
        add_segment(hex($1), hex($2), hex($3), $4);
    } else {
        print "stdin:$.: syntax error\n";
    }
}
if (%blocks) {
    my $n_blocks = scalar(keys(%blocks));
    my $n_bytes = 0;
    $n_bytes += $_->{SIZE} foreach values(%blocks);
    print "$n_bytes bytes in $n_blocks blocks not freed at end of run\n";
    my %blocks_by_callers;
    foreach my $block (values(%blocks)) {
        my ($trimmed_callers) = trim_callers($block->{CALLERS});
        push (@{$blocks_by_callers{$trimmed_callers}}, $block);
    }
    foreach my $callers (sort {@{$b} <=> @{$a}} (values(%blocks_by_callers))) {
        $n_blocks = scalar(@{$callers});
        $n_bytes = 0;
        $n_bytes += $_->{SIZE} foreach @{$callers};
        print "$n_bytes bytes in these $n_blocks blocks were not freed:\n";
        my $i = 0;
        my $max = 5;
        foreach my $block (sort {$a->{LINE} <=> $b->{LINE}} (@{$callers})) {
            printf "\t%d-byte block at 0x%08x allocated on stdin:%d\n",
              $block->{SIZE}, $block->{BASE}, $block->{LINE};
            last if $i++ > $max;
        }
        print "\t...and ", $n_blocks - $max, " others...\n"
          if $n_blocks > $max;
        print "The blocks listed above were allocated by:\n";
        print_callers("\t", ${$callers}[0]->{CALLERS});
    }
}
sub interp_pointer {
    my ($s_ptr) = @_;
    return $s_ptr eq '(nil)' ? 0 : hex($s_ptr);
}

sub allocated {
    my ($line, $s_base, $size, $callers) = @_;
    my ($base) = interp_pointer($s_base);
    return if !$base;
    my ($info) = {LINE => $line,
                  BASE => $base,
                  SIZE => $size,
                  CALLERS => $callers};
    if (exists($blocks{$base})) {
        print "In-use address returned by allocator:\n";
        print "\tInitial allocation:\n";
        print_block("\t\t", $blocks{$base});
        print "\tNew allocation:\n";
        print_block("\t\t", $info);
    }
    $blocks{$base} = $info;
}

sub claimed {
    my ($line, $s_base, $callers) = @_;
    my ($base) = interp_pointer($s_base);
    return if !$base;
    if (exists($blocks{$base})) {
	$blocks{$base}{LINE} = $line;
	$blocks{$base}{CALLERS} = $callers;
    } else {
        printf "Claim asserted on not-in-use block 0x%08x by:\n", $base;
	print_callers('', $callers);
    }
}

sub freed {
    my ($line, $s_base, $callers) = @_;
    my ($base) = interp_pointer($s_base);
    return if !$base;

    if (!delete($blocks{$base})) {
        printf "Bad free of not-allocated address 0x%08x on stdin:%d by:\n", $base, $line;
        print_callers('', $callers);
    }
}

sub print_block {
    my ($prefix, $info) = @_;
    printf '%s%d-byte block at 0x%08x allocated on stdin:%d by:' . "\n",
      $prefix, $info->{SIZE}, $info->{BASE}, $info->{LINE};
    print_callers($prefix, $info->{CALLERS});
}

sub print_callers {
    my ($prefix, $callers) = @_;
    foreach my $pc (split(' ', $callers)) {
        print "$prefix\t", lookup_pc($pc), "\n";
    }
}

our (%cache);
sub lookup_pc {
    my ($s_pc) = @_;
    if (defined($binary)) {
        my ($pc) = hex($s_pc);
        my ($output) = "$s_pc: ";
        if (!exists($cache{$pc})) {
            open(A2L, "$a2l -fe $binary --demangle $s_pc|");
            chomp(my $function = <A2L>);
            chomp(my $line = <A2L>);
            close(A2L);
            if ($function eq '??') {
                ($function, $line) = lookup_pc_by_segment($pc);
            }
            $line =~ s/^(\.\.\/)*//;
            $line = "..." . substr($line, -25) if length($line) > 28;
            $cache{$pc} = "$s_pc: $function ($line)";
        }
        return $cache{$pc};
    } else {
        return "$s_pc";
    }
}

sub trim_callers {
    my ($in) = @_;
    my (@out);
    foreach my $pc (split(' ', $in)) {
        my $xlated = lookup_pc($pc);
        if ($xlated =~ /\?\?/) {
            push(@out, "...") if !@out || $out[$#out] ne '...';
        } else {
            push(@out, $pc);
        }
    }
    return join(' ', @out);
}

sub search_path {
    my ($target) = @_;
    for my $dir (split (':', $ENV{PATH})) {
	my ($file) = "$dir/$target";
	return $file if -e $file;
    }
    return undef;
}

sub add_segment {
    my ($vm_start, $vm_end, $vm_pgoff, $file) = @_;
    for (my $i = 0; $i <= $#segments; $i++) {
        my ($s) = $segments[$i];
        next if $vm_end <= $s->{START} || $vm_start >= $s->{END};
        if ($vm_start <= $s->{START} && $vm_end >= $s->{END}) {
            splice(@segments, $i, 1);
            --$i;
        } else {
            $s->{START} = $vm_end if $vm_end > $s->{START};
            $s->{END} = $vm_start if $vm_start <= $s->{END};
        }
    }
    push(@segments, {START => $vm_start,
                     END => $vm_end,
                     PGOFF => $vm_pgoff,
                     FILE => $file});
    @segments = sort { $a->{START} <=> $b->{START} } @segments;
}

sub binary_search {
    my ($array, $value) = @_;
    my $l = 0;
    my $r = $#{$array};
    while ($l <= $r) {
        my $m = int(($l + $r) / 2);
        my $e = $array->[$m];
        if ($value < $e->{START}) {
            $r = $m - 1;
        } elsif ($value >= $e->{END}) {
            $l = $m + 1;
        } else {
            return $e;
        }
    }
    return undef;
}

sub read_sections {
    my ($file) = @_;
    my (@sections);
    open(OBJDUMP, "$objdump -h $file|");
    while (<OBJDUMP>) {
        my $ptr = "([0-9a-fA-F]+)";
        my ($name, $size, $vma, $lma, $file_off)
          = /^\s*\d+\s+(\S+)\s+$ptr\s+$ptr\s+$ptr\s+$ptr/
            or next;
        push(@sections, {START => hex($file_off),
                         END => hex($file_off) + hex($size),
                         NAME => $name});
    }
    close(OBJDUMP);
    return [sort { $a->{START} <=> $b->{START} } @sections ];
}

our %file_to_sections;
sub segment_to_section {
    my ($file, $file_offset) = @_;
    if (!defined($file_to_sections{$file})) {
        $file_to_sections{$file} = read_sections($file);
    }
    return binary_search($file_to_sections{$file}, $file_offset);
}

sub address_to_segment {
    my ($pc) = @_;
    return binary_search(\@segments, $pc);
}

sub lookup_pc_by_segment {
    return ('??', 0) if !defined($objdump);

    my ($pc) = @_;
    my ($segment) = address_to_segment($pc);
    return ('??', 0) if !defined($segment) || $segment->{FILE} eq '';

    my ($file_offset) = $pc - $segment->{START} + $segment->{PGOFF};
    my ($section) = segment_to_section($segment->{FILE}, $file_offset);
    return ('??', 0) if !defined($section);

    my ($section_offset) = $file_offset - $section->{START};
    open(A2L, sprintf("%s -fe %s --demangle --section=$section->{NAME} 0x%x|",
                      $a2l, $segment->{FILE}, $section_offset));
    chomp(my $function = <A2L>);
    chomp(my $line = <A2L>);
    close(A2L);

    return ($function, $line);
}

# Local Variables:
# mode: perl
# End: