exmap.pm

内存管理工具Exmap。该工具比 ps 或 top 更精确

}

sub add_map
{
    my $s = shift;
    my $map = shift;
    
    push @{$s->{_maps}}, $map;
    return 1;
}

sub add_proc
{
    my $s = shift;
    my $proc = shift;

    my %existing = map { $_ => 1 } $s->procs;
    push @{$s->{_procs}}, $proc unless $existing{$proc};
    
    return 1;
}


# ------------------------------------------------------------
package Exmap::Vma;
use base qw/Exmap::Obj/;

use constant ANON_NAME => "[anon]";
use constant VDSO_NAME => "[vdso]";

sub _init
{
    my $s = shift;
    $s->{_page_pool} = shift;
    $s->{_pages} = [];
    return $s;
}

sub page_pool { return $_[0]->{_page_pool}; }

sub parse_line
{
    my $s = shift;
    my $line = shift;
    
    my %info;

    @info{qw(hex_start hex_end perms hex_offset)}
	= ($line =~ /^([0-9a-f]+)-([0-9a-f]+)\s+(\S+)\s+([0-9a-f]+)/);

    if (not defined $info{hex_start}) {
	warn("Can't parse line [$line]");
	return undef;
    }
    $info{file} = substr($line, 49) if length $line >= 49;
    
    $info{file} ||= ANON_NAME;

    $s->{info} = \%info;

    $s->_calculate_info or return undef;

    return 1;
}

sub _calculate_info
{
    my $s = shift;

    my $info = $s->{info};

    # On 64-bit platforms, addresses are > 32-bit (duh) but the 'int'
    # type is still 32-bit. So perl warns here.
    { # New scope for local warning var
	local $^W = 0;
	$info->{start} = hex $info->{hex_start};
	$info->{offset} = hex $info->{hex_offset};
	$info->{end} = hex $info->{hex_end};
    }
    $info->{vm_size} = $info->{end} - $info->{start};

    return 1
}

sub add_page
{
    my $s = shift;
    my $page_cookie = shift;

    # Record all pages, in order
    push @{$s->{_pages}}, $page_cookie;

    $s->{_page_pool}->{$page_cookie}++;
}

sub is_vdso { return $_[0]->{info}->{file} eq VDSO_NAME; }

sub is_file_backed
{
    my $s = shift;
    # Names like [anon], [heap], and [vdso] don't count as file backed
    return  !($s->{info}->{file} =~ /^\[.*\]$/);
}

sub _addr_to_pgnum
{
    my $s = shift;
    my $addr = shift;

    if ($addr >= $s->{info}->{end}) {
	warn("$addr is beyond vma end " . $s->{info}->{end});
	return undef;
    }
    
    my $pgnum = Elf::page_align_down($addr);
    $pgnum -= $s->{info}->{start};
    if ($pgnum < 0) {
	warn("$addr is less than vma start " . $s->{info}->{start});
	return undef;
    }
#    $pgnum /= Elf::PAGE_SIZE;
    $pgnum >>= Elf::PAGE_SIZE_SHIFT;

    return $pgnum;
}

sub get_pages_for_range
{
    my $s = shift;
    my $range = shift;

    return undef unless $range->size > 0;

    my $vma_fname = $s->{info}->{file};
    
    my $start_pgnum = $s->_addr_to_pgnum($range->start);
    return undef unless defined $start_pgnum;
    my $end_pgnum = $s->_addr_to_pgnum($range->end - 1);
    return undef unless defined $end_pgnum;

    if ($start_pgnum == $end_pgnum) {
	my $page_cookie = $s->{_pages}->[$start_pgnum];
	unless (defined $page_cookie) {
	    warn("Can't find page for pgnum $start_pgnum in $vma_fname");
	    return undef;
	}
	return [{
		 page => $page_cookie,
		 bytes => $range->size,
		}];
    }


    my @info;
    my $page_cookie;
    
    $page_cookie = $s->{_pages}->[$start_pgnum];
    unless (defined $page_cookie) {
	warn("Can't find page for pgnum $start_pgnum in $vma_fname");
	return undef;
    }
    push @info, { page => $page_cookie,
		  bytes => Elf::PAGE_SIZE
		  - ($range->start - Elf::page_align_down($range->start))};
    
    $page_cookie = $s->{_pages}->[$end_pgnum];
    unless (defined $page_cookie) {
	warn("Can't find page for pgnum $end_pgnum in $vma_fname");
	return undef;
    }
    push @info, { page => $page_cookie,
		  bytes =>
		  $range->end - Elf::page_align_down($range->end - 1) };

    for (my $pgnum = $start_pgnum+1; $pgnum <= $end_pgnum-1; ++$pgnum) {
	$page_cookie = $s->{_pages}->[$pgnum];
	unless (defined $page_cookie) {
	    warn("Can't find page for pgnum $pgnum in $vma_fname");
	    return undef;
	}
	push @info, { page => $page_cookie,
		      bytes => Elf::PAGE_SIZE };
    }

    return \@info;
}

sub range
{
    my $s = shift;
    # TODO - do we call this often enough to cache this value?
    return Range->new($s->{info}->{start}, $s->{info}->{end});
}

# Come up with a list of elf maps which exactly cover this vma.  We
# can refer back to the previous vma & file to clarify the various
# cases.
#
# Cases: (1) This is an elf backed vma.  Then for each loadable
# segment, we calculate the elf address->vma address offset and work
# out which how much of the segment overlaps our address space. We
# turn those into maps and any holes into anon maps.
#
# (2a) This is not a file backed vma
# AND previous is file backed
# AND previous file is elf
# AND this vma is contiguous with the previous
# In which case we take the previous vma's segments and offsets
# and see if we have an overlap. We assert that the overlap will
# be at the beginning of this vma.
# Any remainder gets added turned into an anon map
#
# (2b) This is not a file backed vma and some or all of the
# previous conditions do not hold. In which case we turn the entire vma
# into an anon map.
#
# We roll 2a and 2b together, by doing (2b) from a calculated
# start address.
sub calc_maps
{
    my $s = shift;
    my $file = shift;
    my $previous_vma = shift;
    my $previous_file = shift;
    my $pid = shift; # For debugging

    my @maps;
    my @segs;

    ::debug(sprintf "%d: calc_maps", $pid);
    if ($file->is_elf) {
	# Case 1
	@segs = $file->elf->loadable_segments if $file->is_elf;

	foreach my $seg (@segs) {
	    my $seg_to_mem = $s->_get_seg_to_mem($seg);
	    my $seg_mem_range = $seg->mem_range->add($seg_to_mem);
	    my $subrange = $seg_mem_range->intersect($s->range);
	    next unless $subrange && $subrange->size > 0;
	    my $elf_subrange = $subrange->subtract($seg_to_mem);
	    my $map = Exmap::Map->new($s, $subrange, $elf_subrange);

	    ::debug(sprintf "%d: added elf map %s", $pid, $map->to_string);
	    push @maps, $map;
	    $file->add_map($map);
	}

	# Add holes
	my @mem_ranges = map { $_->mem_range } @maps;
	my $hole_ranges = $s->range->invert_list(@mem_ranges);
	my @hole_maps = map {
	    my $hmap = Exmap::Map->new($s, $_);
	    ::debug(sprintf "%d: added hole map %s", $pid, $hmap->to_string);
	    $file->add_map($hmap);
	    $hmap;
	} @$hole_ranges if $hole_ranges;
	
	push @maps, @hole_maps;
    }
    else {
	# Cases 2a and 2b
	my $non_elf_map;
	if ($previous_vma
	    && $previous_file
	    && $previous_vma->is_file_backed
	    && $previous_file->is_elf
	    && $s->range->start == $previous_vma->range->end) {

	    # Case 2a - the elf segment(s) could be continuing
	    # from the previous vma

	    my @prev_segs = $previous_file->elf->loadable_segments;
	    my $non_elf_start = $s->{info}->{start};
	    
	    # TODO - this is cut-and-paste from previous (with some
	    # differences). Make this a vma method.
	    foreach my $seg (@prev_segs) {

		my $seg_to_mem = $previous_vma->_get_seg_to_mem($seg);
		my $seg_mem_range = $seg->mem_range->add($seg_to_mem);
		my $subrange = $seg_mem_range->intersect($s->range);
		next unless $subrange && $subrange->size > 0;

		my $elf_subrange = $subrange->subtract($seg_to_mem);
		my $map = Exmap::Map->new($s, $subrange, $elf_subrange);
		$non_elf_start = $subrange->end;
		
		::debug(sprintf "%d: added elf cont map %s",
			$pid, $map->to_string);
		push @maps, $map;
		$previous_file->add_map($map);
	    }
	    
	    if ($non_elf_start < $s->{info}->{end}) {
		$non_elf_map = Exmap::Map->new($s,
					       Range->new($non_elf_start,
							  $s->{info}->{end},
							  undef));
		::debug(sprintf "%d: added non-elf map %s",
			$pid, $non_elf_map->to_string);
	    }
	}
	else {
	    # We just cover this vma with a non-elf range
	    $non_elf_map = Exmap::Map->new($s, $s->range, undef);
	    ::debug(sprintf "%d: added non-elf map %s",
		    $pid, $non_elf_map->to_string);
	}
	if ($non_elf_map) {
	    push @maps, $non_elf_map;
	    $file->add_map($non_elf_map);
	}
    }

    # Ensure they're in the right order.
    @maps = sort { $a->mem_range->start <=> $b->mem_range->start } @maps;

    # Sanity-check the maps
    my @ranges = map { $_->mem_range } @maps;
    if ($ranges[0]->start != $s->range->start) {
	warn sprintf("%d: first map not at start 0x%08x: %s",
	    $pid, $s->range->start, $ranges[0]->to_string);
	return ();
    }
    if ($ranges[-1]->end != $s->range->end) {
	warn sprintf("%d: last map not at end 0x%08x: %s",
	    $pid, $s->range->end, $ranges[-1]->to_string);
	return ();
    }

    my $last_range;
    foreach my $range (@ranges) {
	unless ($range->size > 0) {
	    warn sprintf("%d: zero length map %s", $pid, $range->to_string);
	    return ();
	}
	if ($last_range) {
	    unless ($last_range->end == $range->start) {
		warn sprintf("%d: Invalid map list %s, %s",
			     $pid,
			     $last_range->to_string,
			     $range->to_string);
		return ();
	    }
	}
	$last_range = $range;
    }

    return @maps;
}


sub _get_seg_to_mem
{
    my $s = shift;
    my $seg = shift;

    # Offset isn't valid unless we have a backing file
    return undef unless $s->is_file_backed;
    
    my $segmem_base = $seg->mem_range->start - $seg->offset;
    my $vmamem_base = $s->{info}->{start} - $s->{info}->{offset};
    return $vmamem_base - $segmem_base;
}


# ------------------------------------------------------------
package Exmap::Map;
use base qw/Exmap::Obj/;

sub _init
{
    my $s = shift;
    $s->{_vma} = shift;
    $s->{_mem_range} = shift;
    $s->{_elf_range} = shift;	# Optional - undef if not file backed

    if ($s->elf_range && $s->mem_range->size != $s->elf_range->size) {
	warn("Mem range != Elf mem range");
	return undef;
    }
    return $s;
}

sub mem_range { return $_[0]->{_mem_range}; }
sub elf_range { return $_[0]->{_elf_range}; }
sub _vma { return $_[0]->{_vma}; }

sub elf_to_mem_offset
{
    my $s = shift;
    return $s->mem_range->start - $s->elf_range->start;
}

sub elf_to_mem_range
{
    my $s = shift;
    my $elf_range = shift;

    unless ($s->elf_range->contains_range($elf_range)) {
	warn("Range " . $elf_range->to_string . " not contained within "
	     . $s->elf_range->to_string);
	return undef;
    }

    return $elf_range->add($s->elf_to_mem_offset);
}


sub sizes_for_mem_range
{
    my $s = shift;
    my $mrange = shift; # Optional -covers whole map if unspecified.

    my $subrange = $mrange
	? $s->mem_range->intersect($mrange)
	    : $s->mem_range;

    my $sizes = Exmap::Sizes->new;
    return $sizes unless $subrange->size > 0;

    my $infolist = $s->_vma->get_pages_for_range($subrange);
    my $pagepool = $s->_vma->page_pool;
    
    $sizes->{vm} = $subrange->size;

    my $page_cookie;
    my $count;
    foreach my $info (@$infolist) {
	$page_cookie = $info->{page};
	$count = $pagepool->{$page_cookie};
	die ("Zero count in pagepool for $page_cookie") unless $count > 0;

	if (Exmap::Page::is_mapped($page_cookie)) {
	    $sizes->{eff_mapped} += $info->{bytes} / $count;
	    $sizes->{mapped} += $info->{bytes};
	    $sizes->{sole_mapped} += $info->{bytes}
		if ($count == 1);

	    if (Exmap::Page::is_resident($page_cookie)) {
		$sizes->{eff_resident} += $info->{bytes} / $count;
		$sizes->{resident} += $info->{bytes};
		if (Exmap::Page::is_writable($page_cookie)) {
		    $sizes->{writable} += $info->{bytes};
		}
	    }
	}
    }

    return $sizes;
}

sub to_string
{
    my $s = shift;
    return "MAP: MEM "
	. $s->mem_range->to_string
	    . " ELF "
		. ($s->elf_range ? $s->elf_range->to_string : "undef")
		    . " FILE " . $s->_vma->{info}->{file};
    
}

# ------------------------------------------------------------
package Exmap::Page;

# We encode the info in the page cookie directly, to reduce storage.
# We could use a blessed scalar ref as an object, but that would be
# two scalars per page cookie, so we use static methods instead.

sub line_to_cookie
{
    my $line = shift;
    my ($resident, $writable, $cookie) = split(/\s+/, $line);

    $cookie = hex $cookie;
    $cookie <<= 2; # Make room for flag bits
    $cookie += $resident ? 2 : 0;
    $cookie += $writable ? 1 : 0;
    return $cookie;
}

sub is_resident { return $_[0] & 2; }
sub is_writable { return $_[0] & 1; }
sub is_mapped { return $_[0] != 0 }
sub is_swapped
{
    my $cookie = shift;
    return is_mapped($cookie) && !is_resident($cookie);
}

# ------------------------------------------------------------
package Exmap::Sizes;

sub new
{
    my $c = shift;
    my $s = {};
    bless $s, $c;
    foreach my $key ($s->keys) {
	$s->{$key} = 0;
    }
    $s->{_scale_factor} = 1;
    $s->{_scale_name} = "";
    return $s;
}

my %SIZE_NAMES = (
		  eff_mapped => "Eff. Mapped",
		  eff_resident => "Eff. Resident",
		  mapped => "Mapped",
		  resident =>  "Resident",
		  sole_mapped => "Sole Mapped",
		  vm => "VM",
		  writable => "Writable",
		 );

my @KEYS = sort keys %SIZE_NAMES;
sub keys
{
    # Bit of a cheat, we want the eff_ ones first and the alphasort
    # to the front. :-/
    return @KEYS;
}

# All the svals, in the same order returned by ->keys
sub multi_svals
{
    my $s = shift;
    return map { $s->sval($_) } @_;
}

sub scale_kbytes
{
    my $s = shift;
    $s->_scale_factor(1024);
    $s->_scale_name("K");
}

sub scale_mbytes
{
    my $s = shift;
    $s->_scale_factor(1024*1024);
    $s->_scale_name("Mbytes");
}

sub _scale_factor
{
    my $s = shift;
    my $scale_factor = shift;
    if ($scale_factor) {
	$s->{_scale_factor} = $scale_factor;
    }
    return $s->{_scale_factor};
}

sub _scale_name
{
    my $s = shift;
    my $val = shift;
    if ($val) {
	$s->{_scale_name} = $val
    }
    return $s->{_scale_name};
}

# Return the value divided by the current scaling factor, to 2 dec places
sub sval
{
    my $s = shift;
    my $key = shift;
    my $val = $s->{$key};
    unless (defined $val) {
	warn "Undefined val for key [$key]";
	return undef;
    }
    $val /= $s->_scale_factor;
    $val *= 100;
    $val = int $val;
    $val /= 100;
    return $val;
}

sub key_name
{
    my $s = shift;
    my $key = shift;
    return $SIZE_NAMES{$key} . " " . $s->_scale_name;
}

sub add
{
    my $s = shift;
    my $r = shift;

    foreach my $key ($r->keys) {
	my $val = $r->{$key};
	die("undefined size for $key")
	    unless defined $val;
	$s->{$key} += $val;
    }
    return 1;
}

1;