exmap.pm

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

#
# (c) John Berthels 2005 <[e-mail]>. See COPYING for license.
#
use Elf;
use strict;
use warnings;

my $DEBUG_ON = $ENV{EXMAP_DEBUG};

sub debug
{
    print STDERR join(":", @_), "\n" if $DEBUG_ON;
}

# ------------------------------------------------------------
package Exmap::Obj;

my $OBJ_LIFETIME_DEBUG = 0;

sub _init { return shift; }

sub new
{
    my $c = shift;
    $c = ref $c if ref $c;
    my $s = {};
    bless $s, $c;
    print "C: $s\n" if $OBJ_LIFETIME_DEBUG;
    return $s->_init(@_);
}

sub DESTROY
{
    my $s = shift;
    print "D: $s\n" if $OBJ_LIFETIME_DEBUG;
}

    
# ------------------------------------------------------------
# Map page cookie -> usage count
package Exmap::PagePool;
use base qw/Exmap::Obj/;

# This used to be an object with accessors to add pages and read
# counts.  But they showed up as very hot in profiling, and accessing
# via a straight hash is still fairly clean.

sub clear
{
    my $s = shift;
    %$s = ();
    #    print "C:\n";
}

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

sub clear
{
    my $s = shift;
    %$s = ();
}

sub name_to_file
{
    my $s = shift;
    my $fname = shift;
    return $s->{$fname};
}

sub get_or_make_file
{
    my $s = shift;
    my $fname = shift;

    my $file = $s->name_to_file($fname);
    return $file if $file;
    $s->{$fname} = Exmap::File->new($fname);
    return $s->{$fname};
}

sub files
{
    my $s = shift;
    return values %$s;
}

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

sub _init
{
    my $s = shift;
    $s->{_procs} = [];
    $s->{_pid_to_proc} = {};
    $s->{_page_pool} = Exmap::PagePool->new;
    $s->{_file_pool} = Exmap::FilePool->new;
    return $s;
}

sub procs { return @{$_[0]->{_procs}}; }
sub page_pool { return $_[0]->{_page_pool}; }
sub file_pool { return $_[0]->{_file_pool}; }
sub files { return $_[0]->file_pool->files; }

sub pids
{
    my $s = shift;
    return keys %{$s->{_pid_to_proc}};
}

sub pid_to_proc
{
    my $s = shift;
    my $pid = shift;
    return $s->{_pid_to_proc}->{$pid};
}

sub num_procs
{
    my $s = shift;
    return scalar($s->procs);
}

sub _all_pids
{
    my $s = shift;
    my @pids = map { s!^/proc/!!; $_; } glob "/proc/[0-9]*";
    return sort { $a <=> $b } @pids;
}

sub load
{
    my $s = shift;
    my $progress = shift;
    my $test_info = shift;

    $s->_load_procs($test_info)
	or return undef;

    $progress->number_of_ticks(scalar $s->procs)
	if $progress;

    $s->_calculate_file_mappings($progress)
	or return undef;

    $progress->finished if $progress;
    
    return 1;
}

sub _load_procs
{
    my $s = shift;
    my $test_info = shift;
    
    my $pp = $s->page_pool;
    $pp->clear;
    
    # Don't monitor ourselves, our VMAs etc will change too much as we run
    my @pids = grep { $_ != $$ } $s->_all_pids();
    @pids = @{$test_info->{pids}} if $test_info;

    my @procs;
    foreach my $pid (@pids) {

	my $proc_prefix = "/proc";
	$proc_prefix = $test_info->{proc} if $test_info;
	my $exmap_data = $test_info->{exmap_files}->{$pid};
	
	my $proc = Exmap::Process->new($pid, $proc_prefix);
	unless ($proc->load($pp, $exmap_data)) {
	    warn("Can't load info for pid $pid");
	    next;
	}
	push @procs, $proc if $proc->has_mm;
    }
    
    $s->{_procs} = \@procs;
    $s->{_pid_to_proc} = { map { $_->pid => $_ } @procs };
    
    return scalar @procs;
}

sub _calculate_file_mappings
{
    my $s = shift;
    my $progress = shift;
    
    foreach my $proc ($s->procs) {
	warn("Failed to process maps for pid ", $proc->pid)
	    unless $proc->_calc_vma_maps($s->file_pool);
	$progress->tick($proc->pid . ": " . $proc->cmdline)
	    if $progress;
    }
    return scalar $s->files;
}


# ------------------------------------------------------------
# Abstract base class for callers of Exmap::load to get progress updates
package Exmap::Progress;
use base qw/Exmap::Obj/;

# Called when the load initialises. You can override this if you wish.
sub number_of_ticks
{
    my $s = shift;
    $s->{_num_ticks} = shift;
    return 1;
}

# Called whenever we tick. You'll want to override this.
sub tick
{
    my $s = shift;
    my $text = shift;
    return 1;
}

# Called after the last tick. You'll probably want to override this.
sub finished
{
    my $s = shift;
    my $text = shift;
    return 1;
}

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

use constant EXMAP_FILE => "/proc/exmap";

sub _init
{
    my $s = shift;
    $s->{_pid} = shift;
    $s->{_proc_prefix} = shift || "/proc";
    $s->{_exe_name} = readlink "$s->{_proc_prefix}/$s->{_pid}/exe";
    my @cmdline = split /[ \0]/, `cat $s->{_proc_prefix}/$s->{_pid}/cmdline`;
    if (@cmdline > 1) {
	# Hack so we can see [kdeinit]
	if ($cmdline[1] =~ /^\[/ ) {
	    @cmdline = @cmdline[0..1];
	}
	else {
	    @cmdline = $cmdline[0];
	}
    }
    $s->{_cmdline} = join(" ", @cmdline);
    $s->{_files} = {};
    return $s;
}

sub load
{
    my $s = shift;
    my $page_pool = shift;
    my $test_exmap_file = shift; # Or undef for the real exmap

    unless ($s->_load_vmas($page_pool)) {
	warn "Can't load vmas for " . $s->pid;
	return undef;
    }
    return 1 unless $s->has_mm;
    unless ($s->_load_page_info($test_exmap_file)) {
	warn "Can't load page info for " . $s->pid;
	return undef;
    }
    return 1;
}

sub pid { return $_[0]->{_pid}; }
sub exe_name { return $_[0]->{_exe_name}; }
sub cmdline { return $_[0]->{_cmdline}; }
sub _vmas { return @{$_[0]->{_vmas}}; }
sub has_mm
{
    my $s = shift;
    return exists $s->{_vmas} && scalar $s->_vmas > 0;
}
sub maps { return @{$_[0]->{_maps}}; }
sub files { return values %{$_[0]->{_files}}; }

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

    return $s->{_start_to_vma}->{$addr};
}

sub add_file
{
    my $s = shift;
    my $file = shift;

    # Store as a hash for easy uniqueness. Hash keys are stringified,
    # so we need to store the obj reference as a value
    $s->{_files}->{$file} = $file;
}

sub _has_file
{
    my $s = shift;
    my $file = shift;

    my @matches = grep { $_ eq $file } $s->files;
    warn("File ", $file->name, " present in process ", $s->pid,
	 " more than once")
	if (scalar @matches > 1);
    return scalar @matches == 1;
}

sub _restrict_maps_to_file
{
    my $s = shift;
    my $file = shift;
    my @maps = @_;

    unless ($file) {
	warn("No file to specified");
	return ();
    }
    unless ($s->_has_file($file)) {
	warn("PID ", $s->pid, " doesn't have file ", $file->name);
	return ();
    }

    my %count;
    my @file_maps = $file->maps;
    foreach my $map (@maps, @file_maps) {
	$count{$map}++;
    }
    # Only keep those in both arrays.
    @maps = grep { $count{$_} > 1 } @maps;

    return @maps;
}

sub _refine_maps_to_elf_range
{
    my $s = shift;
    my $elf_range = shift;
    my @maps = @_;

    return () unless $elf_range->size > 0;

    my @refinements;
    
    foreach my $map (@maps) {
	if ($map->elf_range
	    && $map->elf_range->overlaps($elf_range)) {
	    my $subrange = $elf_range->intersect($map->elf_range);
	    my $mem_range = $map->elf_to_mem_range($subrange);
	    push @refinements, { map => $map,
				 range => $mem_range };
	}
    }

    unless (@refinements) {
	my $warnstr = $s->pid . ": no map refinements for elf range "
	    . $elf_range->to_string. ": "
		. join(", ", map { $_->elf_range
				       ? $_->elf_range->to_string
				   : "undef" } @maps);
	warn($warnstr);
    }
    
    return @refinements;
}


# This takes on optional 'file' parameter, which may also be followed
# by an optional 'elf_range' parameter. These are both used to restrict the
# maps to be summed over.
sub sizes
{
    my $s = shift;
    my $file = shift;

    my @maps = $s->maps;
    warn ("No maps in process", $s->pid) unless @maps;

    if ($file) {
	@maps = $s->_restrict_maps_to_file($file, @maps);
	warn ("No maps for file " . $file->name . " in process ", $s->pid)
	    unless @maps;
    }

    my $sizes = Exmap::Sizes->new;
    foreach my $m (@maps) {
	my $subsizes = $m->sizes_for_mem_range;
	$sizes->add($subsizes);
    }

    return $sizes;
}

sub elf_range_sizes
{
    my $s = shift;
    my $file = shift;
    my @elf_ranges = @_;

    my @maps = $s->maps;
    warn ("No maps in process", $s->pid) unless @maps;
    @maps = $s->_restrict_maps_to_file($file, @maps);
    warn ("No maps for file " . $file->name . " in process ", $s->pid)
	unless @maps;

    my @sizes;
    foreach my $elf_range (@elf_ranges) {
	# A list of { map => $map, range => $mem_range }. Undef range
	# implies full map.
	my @refinements = $s->_refine_maps_to_elf_range($elf_range, @maps);
	my $sizes = Exmap::Sizes->new;
	foreach my $r (@refinements) {
	    my $subsizes = $r->{map}->sizes_for_mem_range($r->{range});
	    $sizes->add($subsizes);
	}
	push @sizes, $sizes;
    }

    return @sizes;
}

sub _load_vmas
{
    my $s = shift;
    my $page_pool = shift;

    my $mapfile = "$s->{_proc_prefix}/" . $s->pid . "/maps";
    
    unless (open (M, "< $mapfile")) {
	warn("Can't open mapfile $mapfile: $!");
	return undef;
    }
    my @map_lines = <M>;
    close M;

    # Kernel threads have no maps. Thats OK.
    return 1 if (@map_lines == 0);

    my @vmas;
    foreach my $line (@map_lines) {
	$line =~ s/\r?\n$//;
	my $vma = Exmap::Vma->new($page_pool);
	unless ($vma->parse_line($line)) {
	    warn("Can't create VMA for line $line");
	    next;
	}
	# Don't add the [vdso] map, it doesn't exist as a vma
	# in the kernel.
	push @vmas, $vma unless $vma->is_vdso;
    }
    # Store as hash for fast addr lookup
    $s->{_start_to_vma} = {
		   map { $_->{info}->{start}, $_ } @vmas
		  };
    # Keep the ordered list
    $s->{_vmas} = \@vmas;
    
    return $s;
}

sub _load_page_info
{
    my $s = shift;
    my $test_exmap_file = shift;

    my $exmap_file = $test_exmap_file ? $test_exmap_file : EXMAP_FILE;
    # Ask exmap about our pid
    if ($test_exmap_file) {
	unless(open (E, "< $exmap_file")) {
	    warn("can't open test exmap file $test_exmap_file");
	    return undef;
	}
    }
    else {
	unless (open(E, "+> $exmap_file")) {
	    warn("can't open $exmap_file for writing : $!");
	    return undef;
	}
	print E $s->pid, "\n";
    }

    my $current_vma;
    my $page_cookie;
    my ($pfn, $swap_entry, $line);
    while ($line = <E>) {
	# Lines are either:
	# Start a new VMA:
	# VMA 0xdeadbeef <npages>
	# or
	# Page info
	# <pfn> <swap_entry>

	if ($line =~ /^VMA/) {
	    # New VMA
	    my ($vma_hex_start, $npages) = $line =~ /^VMA\s+0x(\S+)\s+(\d+)$/;
	    my $vma_start = hex $vma_hex_start;
	    my $vma = $s->_find_vma_by_addr($vma_start);
	    unless ($vma) {
		# TODO - try reload completely here?
		warn("PID ", $s->pid, " can't find VMA $vma_hex_start");
		return undef;
	    }
	    $current_vma = $vma;
	}
	else {
	    $page_cookie = Exmap::Page::line_to_cookie($line);
	    $current_vma->add_page($page_cookie);
	}
    }
    close E;

    return 1;
}


sub _calc_vma_maps
{
    my $s = shift;
    my $filepool = shift;

    my @maps; # Accumulate all the per-proc maps in here
    my @vmas = $s->_vmas;

    my $previous_vma;
    my $previous_file;
    foreach my $vma (@vmas) {
	my $file = $filepool->get_or_make_file($vma->{info}->{file});
	$file->add_proc($s);
	my @vma_maps = $vma->calc_maps($file,
				       $previous_vma,
				       $previous_file,
				       $s->pid);

	warn sprintf("%d: Can't calc maps for vma 0x%08x : %s",
		     $s->pid, $vma->{info}->{start}, $file->name)
	    unless @vma_maps;
	
	push @maps, @vma_maps;
	$s->add_file($file);
	$previous_vma = $vma;
	$previous_file = $file;
    }

    my @ranges = map { $_->mem_range } @maps;
    my $last_range;
    foreach my $range (@ranges) {
	if ($last_range) {
	    if ($range->overlaps($last_range)) {
		warn sprintf("%d: Invalid map list %s, %s",
			     $s->pid,
			     $last_range->to_string,
			     $range->to_string);
		return undef;
	    }
	}
	$last_range = $range;
    }

    $s->{_maps} = \@maps;

    return scalar @maps;
}


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

sub _init
{
    my $s = shift;
    $s->{_name} = shift;
    $s->{_maps} = [];
    $s->{_procs} = [];
    if (-f $s->name) {
	$s->{_elf} = Elf->new($s->name,
			      1); # Suppress warning if not elf
    }
    return $s;
}

sub name { return $_[0]->{_name}; }
sub procs { return @{$_[0]->{_procs}}; }
sub elf { return $_[0]->{_elf}; }
sub is_elf { return $_[0]->elf; } # Mmmm. Sugary.
sub maps { return @{$_[0]->{_maps}}; }

sub sizes
{
    my $s = shift;

    my $sizes = Exmap::Sizes->new;

    foreach my $map ($s->maps) {
	my $subsizes = $map->sizes_for_mem_range;
	$sizes->add($subsizes);
    }
    return $sizes;