## (c) John Berthels 2005 <jjberthels@gmail.com>. 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 countpackage 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 updatespackage 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;