mirror of
https://gitlab.winehq.org/wine/wine-gecko.git
synced 2024-09-13 09:24:08 -07:00
1181 lines
36 KiB
Perl
Executable File
1181 lines
36 KiB
Perl
Executable File
#!/usr/bin/perl -w
|
||
#
|
||
# This Source Code Form is subject to the terms of the Mozilla Public
|
||
# License, v. 2.0. If a copy of the MPL was not distributed with this
|
||
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||
|
||
# A perl version of Patrick Beard's ``Leak Soup'', which processes the
|
||
# stack crawls from the Boehm GC into a graph.
|
||
|
||
use 5.004;
|
||
use strict;
|
||
use Getopt::Long;
|
||
use FileHandle;
|
||
use IPC::Open2;
|
||
|
||
# Collect program options
|
||
$::opt_help = 0;
|
||
$::opt_detail = 0;
|
||
$::opt_fragment = 1.0; # Default to no fragment analysis
|
||
$::opt_nostacks = 0;
|
||
$::opt_nochildstacks = 0;
|
||
$::opt_depth = 9999;
|
||
$::opt_noentrained = 0;
|
||
$::opt_noslop = 0;
|
||
$::opt_showtype = -1; # default to listing all types
|
||
$::opt_stackrefine = "C";
|
||
@::opt_stackretype = ();
|
||
@::opt_stackskipclass = ();
|
||
@::opt_stackskipfunc = ();
|
||
@::opt_typedivide = ();
|
||
|
||
GetOptions("help", "detail", "format=s", "fragment=f", "nostacks",
|
||
"nochildstacks", "depth=i", "noentrained", "noslop", "showtype=i",
|
||
"stackrefine=s", "stackretype=s@", "stackskipclass=s@", "stackskipfunc=s@",
|
||
"typedivide=s@"
|
||
);
|
||
|
||
if ($::opt_help) {
|
||
die "usage: leak-soup.pl [options] <leakfile>
|
||
--help Display this message
|
||
--detail Provide details of memory sweeping from child to parents
|
||
--fragment=ratio Histogram bucket ratio for fragmentation analysis
|
||
# --nostacks Do not compute stack traces
|
||
# --nochildstacks Do not compute stack traces for entrained objects
|
||
# --depth=<max> Only compute stack traces to depth of <max>
|
||
# --noentrained Do not compute amount of memory entrained by root objects
|
||
--noslop Don't ignore low bits when searching for pointers
|
||
--showtype=<i> Show memory usage histogram for most-significant <i> types
|
||
--stackrefine={F|C} During stack based refinement, use 'F'ull name name or just 'C'lass
|
||
--stackretype=type Use allocation stack to refine vague types like void*
|
||
--stackskipclass=class When refining types, ignore stack frames from 'class'
|
||
--stackskipfunc=func When refining types, ignore stack frames for 'func'
|
||
--typedivide=type Subdivide 'type' based on objects pointing to each instance
|
||
";
|
||
}
|
||
|
||
# This is the table that keeps a graph of objects. It's indexed by the
|
||
# object's address (as an integer), and refers to a simple hash that
|
||
# has information about the object's type, size, slots, and allocation
|
||
# stack.
|
||
%::Objects = %{0};
|
||
|
||
# This will be a list of keys to (addresses in) Objects, that is sorted
|
||
# It gets used to evaluate overlaps, calculate fragmentation, and chase
|
||
# parent->child (interior) pointers.
|
||
@::SortedAddresses = [];
|
||
|
||
# This is the table that keeps track of memory usage on a per-type basis.
|
||
# It is indexed by the type name (string), and keeps a tally of the
|
||
# total number of such objects, and the memory usage of such objects.
|
||
%::Types = %{0};
|
||
$::TotalSize = 0; # sum of sizes of all objects included $::Types{}
|
||
|
||
# This is an array of leaf node addresses. A leaf node has no children
|
||
# with memory allocations. We traverse them sweeping memory
|
||
# tallies into parents. Note that after all children have
|
||
# been swept into a parent, that parent may also become a leaf node.
|
||
@::Leafs = @{0};
|
||
|
||
|
||
|
||
|
||
#----------------------------------------------------------------------
|
||
#
|
||
# Decode arguments to override default values for doing call-stack-based
|
||
# refinement of typename based on contents of the stack at allocation time.
|
||
#
|
||
|
||
# List the types that we need to refine (if any) based on allocation stack
|
||
$::VagueType = {
|
||
'void*' => 1,
|
||
};
|
||
|
||
# With regard to the stack, ignore stack frames in the following
|
||
# overly vague classes.
|
||
$::VagueClasses = {
|
||
# 'nsStr' => 1,
|
||
'nsVoidArray' => 1,
|
||
};
|
||
|
||
# With regard to stack, ignore stack frames with the following vague
|
||
# function names
|
||
$::VagueFunctions = {
|
||
'PL_ArenaAllocate' => 1,
|
||
'PL_HashTableFinalize(PLHashTable *)' => 1,
|
||
'PL_HashTableInit__FP11PLHashTableUiPFPCv_UiPFPCvPCv_iT3PC14PLHashAllocOpsPv' => 1,
|
||
'PL_HashTableRawAdd' => 1,
|
||
'__builtin_vec_new' => 1,
|
||
'_init' => 1,
|
||
'il_get_container(_IL_GroupContext *, ImgCachePolicy, char const *, _NI_IRGB *, IL_DitherMode, int, int, int)' => 1,
|
||
'nsCStringKey::Clone(void) const' => 1,
|
||
'nsCppSharedAllocator<unsigned short>::allocate(unsigned int, void const *)' => 1,
|
||
'nsHashtable::Put(nsHashKey *, void *)' => 1,
|
||
'nsHashtable::nsHashtable(unsigned int, int)' => 1,
|
||
'nsMemory::Alloc(unsigned int)' => 1,
|
||
'nsMemoryImpl::Alloc(unsigned int)' => 1,
|
||
};
|
||
|
||
sub init_stack_based_type_refinement() {
|
||
# Move across stackretype options, or use default values
|
||
if ($#::opt_stackretype < 0) {
|
||
print "Default --stackretype options will be used (since none were specified)\n";
|
||
print " use --stackretype='nothing' to disable re-typing activity\n";
|
||
} else {
|
||
foreach my $type (keys %{$::VagueType}) {
|
||
delete ($::VagueType->{$type});
|
||
}
|
||
if ($#::opt_stackretype == 0 && $::opt_stackretype[0] eq 'nothing') {
|
||
print "Types will not be refined based on call stack\n";
|
||
} else {
|
||
foreach my $type (@::opt_stackretype) {
|
||
$::VagueType->{$type} = 1;
|
||
}
|
||
}
|
||
}
|
||
|
||
|
||
if (keys %{$::VagueType}) {
|
||
print "The following type(s) will be refined based on call stacks:\n";
|
||
foreach my $type (sort keys %{$::VagueType}) {
|
||
print " $type\n";
|
||
}
|
||
print "Equivalent command line argument(s):\n";
|
||
foreach my $type (sort keys %{$::VagueType}) {
|
||
print " --stackretype='$type'";
|
||
}
|
||
print "\n\n";
|
||
|
||
if ($#::opt_stackskipclass < 0) {
|
||
print "Default --stackskipclass options will be used (since none were specified)\n";
|
||
print " use --stackskipclass='nothing' to disable skipping stack frames based on class names\n";
|
||
} else {
|
||
foreach my $type (keys %{$::VagueClasses}) {
|
||
delete ($::VagueClasses->{$type});
|
||
}
|
||
if ($#::opt_stackskipclass == 0 && $::opt_stackskipclass[0] eq 'nothing') {
|
||
print "Types will not be refined based on call stack\n";
|
||
} else {
|
||
foreach my $type (@::opt_stackskipclass) {
|
||
$::VagueClasses->{$type} = 1;
|
||
}
|
||
}
|
||
}
|
||
|
||
if (keys %{$::VagueClasses}) {
|
||
print "Stack frames from the following class(es) will not be used to refine types:\n";
|
||
foreach my $class (sort keys %{$::VagueClasses}) {
|
||
print " $class\n";
|
||
}
|
||
print "Equivalent command line argument(s):\n";
|
||
foreach my $class (sort keys %{$::VagueClasses}) {
|
||
print " --stackskipclass='$class'";
|
||
}
|
||
print "\n\n";
|
||
}
|
||
|
||
|
||
if ($#::opt_stackskipfunc < 0) {
|
||
print "Default --stackskipfunc options will be used (since none were specified)\n";
|
||
print " use --stackskipfunc='nothing' to disable skipping stack frames based on function names\n";
|
||
} else {
|
||
foreach my $type (keys %{$::VagueFunctions}) {
|
||
delete ($::VagueFunctions->{$type});
|
||
}
|
||
if ($#::opt_stackskipfunc == 0 && $::opt_stackskipfunc[0] eq 'nothing') {
|
||
print "Types will not be refined based on call stack\n";
|
||
} else {
|
||
foreach my $type (@::opt_stackskipfunc) {
|
||
$::VagueFunctions->{$type} = 1;
|
||
}
|
||
}
|
||
}
|
||
|
||
if (keys %{$::VagueFunctions}) {
|
||
print "Stack frames from the following function(s) will not be used to refine types:\n";
|
||
foreach my $func (sort keys %{$::VagueFunctions}) {
|
||
print " $func\n";
|
||
}
|
||
print "Equivalent command line argument(s):\n";
|
||
foreach my $func (sort keys %{$::VagueFunctions}) {
|
||
print " --stackskipfunc='$func'";
|
||
}
|
||
print "\n\n";
|
||
}
|
||
}
|
||
}
|
||
|
||
|
||
#----------------------------------------------------------------------
|
||
#
|
||
# Read in the output from the Boehm GC or Trace-malloc.
|
||
#
|
||
sub read_boehm() {
|
||
OBJECT: while (<>) {
|
||
# e.g., 0x0832FBD0 <void*> (80)
|
||
next OBJECT unless /^0x(\S+) <(.*)> \((\d+)\)/;
|
||
my ($addr, $type, $size) = (hex $1, $2, $3);
|
||
|
||
my $object = $::Objects{$addr};
|
||
if (! $object) {
|
||
# Found a new object entry. Record its type and size
|
||
$::Objects{$addr} =
|
||
$object =
|
||
{ 'type' => $type, 'size' => $size };
|
||
} else {
|
||
print "Duplicate address $addr contains $object->{'type'} and $type\n";
|
||
$object->{'dup_addr_count'}++;
|
||
}
|
||
|
||
# Record the object's slots
|
||
my @slots;
|
||
|
||
SLOT: while (<>) {
|
||
# e.g., 0x00000000
|
||
last SLOT unless /^\t0x(\S+)/;
|
||
my $value = hex $1;
|
||
|
||
# Ignore low bits, unless they've specified --noslop
|
||
$value &= ~0x7 unless $::opt_noslop;
|
||
|
||
$slots[$#slots + 1] = $value;
|
||
}
|
||
|
||
$object->{'slots'} = \@slots;
|
||
|
||
if (@::opt_stackretype && (defined $::VagueType->{$type})) {
|
||
# Change the value of type of the object based on stack
|
||
# if we can find an interesting calling function
|
||
VAGUEFRAME: while (<>) {
|
||
# e.g., _dl_debug_message[/lib/ld-linux.so.2 +0x0000B858]
|
||
last VAGUEFRAMEFRAME unless /^(.*)\[(.*) \+0x(\S+)\]$/;
|
||
my ($func, $lib, $off) = ($1, $2, hex $3);
|
||
chomp;
|
||
|
||
my ($class,,$fname) = split(/:/, $func);
|
||
next VAGUEFRAME if (defined $::VagueFunctions->{$func} ||
|
||
defined $::VagueClasses->{$class});
|
||
|
||
# Refine typename and exit stack scan
|
||
$object->{'type'} = $type . ":" .
|
||
(('C' eq $::opt_stackrefine) ?
|
||
$class :
|
||
$func);
|
||
last VAGUEFRAME;
|
||
}
|
||
} else {
|
||
# Save all stack info if requested
|
||
if (! $::opt_nostacks) {
|
||
# Record the stack by which the object was allocated
|
||
my @stack;
|
||
|
||
FRAME: while (<>) {
|
||
# e.g., _dl_debug_message[/lib/ld-linux.so.2 +0x0000B858]
|
||
last FRAME unless /^(.*)\[(.*) \+0x(\S+)\]$/;
|
||
my ($func, $lib, $off) = ($1, $2, hex $3);
|
||
chomp;
|
||
|
||
$stack[$#stack + 1] = $_;
|
||
}
|
||
|
||
$object->{'stack'} = \@stack;
|
||
}
|
||
}
|
||
|
||
# Gotta check EOF explicitly...
|
||
last OBJECT if eof;
|
||
}
|
||
}
|
||
|
||
|
||
#----------------------------------------------------------------------
|
||
#
|
||
# Read input
|
||
#
|
||
init_stack_based_type_refinement();
|
||
read_boehm;
|
||
|
||
|
||
|
||
#----------------------------------------------------------------------
|
||
#
|
||
# Do basic initialization of the type hash table. Accumulate
|
||
# total counts, and basic memory usage (not including children)
|
||
sub load_type_table() {
|
||
# Reset global counter and hash table
|
||
$::TotalSize = 0;
|
||
%::Types = %{0};
|
||
|
||
OBJECT: foreach my $addr (keys %::Objects) {
|
||
my $obj = $::Objects{$addr};
|
||
my ($type, $size, $swept_in, $overlap_count, $dup_addr_count) =
|
||
($obj->{'type'}, $obj->{'size'},
|
||
$obj->{'swept_in'},
|
||
$obj->{'overlap_count'},$obj->{'dup_addr_count'});
|
||
|
||
my $type_data = $::Types{$type};
|
||
if (! defined $type_data) {
|
||
$::Types{$type} =
|
||
$type_data = {'count' => 0, 'size' => 0,
|
||
'max' => $size, 'min' => $size,
|
||
'swept_in' => 0, 'swept' => 0,
|
||
'overlap_count' => 0,
|
||
'dup_addr_count' => 0};
|
||
}
|
||
|
||
if (!$size) {
|
||
$type_data->{'swept'}++;
|
||
next OBJECT;
|
||
}
|
||
$::TotalSize += $size;
|
||
|
||
$type_data->{'count'}++;
|
||
$type_data->{'size'} += $size;
|
||
if (defined $swept_in) {
|
||
$type_data->{'swept_in'} += $swept_in;
|
||
|
||
if ($::opt_detail) {
|
||
my $type_detail_sizes = $type_data->{'sweep_details_size'};
|
||
my $type_detail_counts;
|
||
if (!defined $type_detail_sizes) {
|
||
$type_detail_sizes = $type_data->{'sweep_details_size'} = {};
|
||
$type_detail_counts = $type_data->{'sweep_details_count'} = {};
|
||
} else {
|
||
$type_detail_counts = $type_data->{'sweep_details_count'};
|
||
}
|
||
|
||
my $sweep_details = $obj->{'sweep_details'};
|
||
for my $swept_addr (keys (%{$sweep_details})) {
|
||
my $swept_obj = $::Objects{$swept_addr};
|
||
my $swept_type = $swept_obj->{'type'};
|
||
$type_detail_sizes->{$swept_type} += $sweep_details->{$swept_addr};
|
||
$type_detail_counts->{$swept_type}++;
|
||
}
|
||
}
|
||
}
|
||
if (defined $overlap_count) {
|
||
$type_data->{'overlap_count'} += $overlap_count;
|
||
}
|
||
|
||
if (defined $dup_addr_count) {
|
||
$type_data->{'dup_addr_count'} += $dup_addr_count;
|
||
}
|
||
|
||
if ($type_data->{'max'} < $size) {
|
||
$type_data->{'max'} = $size;
|
||
}
|
||
# Watch out for case where min is produced by a swept object
|
||
if (!$type_data->{'min'} || $type_data->{'min'} > $size) {
|
||
$type_data->{'min'} = $size;
|
||
}
|
||
}
|
||
}
|
||
|
||
|
||
#----------------------------------------------------------------------
|
||
sub print_type_table(){
|
||
if (!$::opt_showtype) {
|
||
return;
|
||
}
|
||
my $line_count = 0;
|
||
my $bytes_printed_tally = 0;
|
||
|
||
# Display type summary information
|
||
my @sorted_types = keys (%::Types);
|
||
print "There are ", 1 + $#sorted_types, " types containing ", $::TotalSize, " bytes\n";
|
||
@sorted_types = sort {$::Types{$b}->{'size'}
|
||
<=> $::Types{$a}->{'size'} } @sorted_types;
|
||
|
||
foreach my $type (@sorted_types) {
|
||
last if ($line_count++ == $::opt_showtype);
|
||
|
||
my $type_data = $::Types{$type};
|
||
$bytes_printed_tally += $type_data->{'size'};
|
||
|
||
if ($type_data->{'count'}) {
|
||
printf "%.2f%% ", $type_data->{'size'} * 100.0/$::TotalSize;
|
||
print $type_data->{'size'},
|
||
"\t(",
|
||
$type_data->{'min'}, "/",
|
||
int($type_data->{'size'} / $type_data->{'count'}),"/",
|
||
$type_data->{'max'}, ")";
|
||
print "\t", $type_data->{'count'},
|
||
" x ";
|
||
}
|
||
print $type;
|
||
|
||
if ($type_data->{'swept_in'}) {
|
||
print ", $type_data->{'swept_in'} sub-objs absorbed";
|
||
}
|
||
if ($type_data->{'swept'}) {
|
||
print ", $type_data->{'swept'} swept away";
|
||
}
|
||
if ($type_data->{'overlap_count'}) {
|
||
print ", $type_data->{'overlap_count'} range overlaps";
|
||
}
|
||
if ($type_data->{'dup_addr_count'}) {
|
||
print ", $type_data->{'dup_addr_count'} duplicated addresses";
|
||
}
|
||
|
||
print "\n" ;
|
||
if (defined $type_data->{'sweep_details_size'}) {
|
||
my $sizes = $type_data->{'sweep_details_size'};
|
||
my $counts = $type_data->{'sweep_details_count'};
|
||
my @swept_types = sort {$sizes->{$b} <=> $sizes->{$a}} keys (%{$sizes});
|
||
|
||
for my $type (@swept_types) {
|
||
printf " %.2f%% ", $sizes->{$type} * 100.0/$::TotalSize;
|
||
print "$sizes->{$type} (", int($sizes->{$type}/$counts->{$type}) , ") $counts->{$type} x $type\n";
|
||
}
|
||
print " ---------------\n";
|
||
}
|
||
}
|
||
if ($bytes_printed_tally != $::TotalSize) {
|
||
printf "%.2f%% ", ($::TotalSize- $bytes_printed_tally) * 100.0/$::TotalSize;
|
||
print $::TotalSize - $bytes_printed_tally, "\t not shown due to truncation of type list\n";
|
||
print "Currently only data on $::opt_showtype types are displayed, due to command \n",
|
||
"line argument '--showtype=$::opt_showtype'\n\n";
|
||
}
|
||
|
||
}
|
||
|
||
#----------------------------------------------------------------------
|
||
#
|
||
# Check for duplicate address ranges is Objects table, and
|
||
# create list of sorted addresses for doing pointer-chasing
|
||
|
||
sub validate_address_ranges() {
|
||
# Build sorted list of address for validating interior pointers
|
||
@::SortedAddresses = sort {$a <=> $b} keys %::Objects;
|
||
|
||
# Validate non-overlap of memory
|
||
my $prev_addr_end = -1;
|
||
my $prev_addr = -1;
|
||
my $index = 0;
|
||
my $overlap_tally = 0; # overlapping object memory
|
||
my $unused_tally = 0; # unused memory between blocks
|
||
while ($index <= $#::SortedAddresses) {
|
||
my $address = $::SortedAddresses[$index];
|
||
if ($prev_addr_end > $address) {
|
||
print "Object overlap from $::Objects{$prev_addr}->{'type'}:$prev_addr-$prev_addr_end into";
|
||
my $test_index = $index;
|
||
my $prev_addr_overlap_tally = 0;
|
||
|
||
while ($test_index <= $#::SortedAddresses) {
|
||
my $test_address = $::SortedAddresses[$test_index];
|
||
last if ($prev_addr_end < $test_address);
|
||
print " $::Objects{$test_address}->{'type'}:$test_address";
|
||
|
||
$::Objects{$prev_addr}->{'overlap_count'}++;
|
||
$::Objects{$test_address}->{'overlap_count'}++;
|
||
my $overlap = $prev_addr_end - $test_address;
|
||
if ($overlap > $::Objects{$test_address}->{'size'}) {
|
||
$overlap = $::Objects{$test_address}->{'size'};
|
||
}
|
||
print "($overlap bytes)";
|
||
$prev_addr_overlap_tally += $overlap;
|
||
|
||
$test_index++;
|
||
}
|
||
print " [total $prev_addr_overlap_tally bytes]";
|
||
$overlap_tally += $prev_addr_overlap_tally;
|
||
print "\n";
|
||
}
|
||
|
||
$prev_addr = $address;
|
||
$prev_addr_end = $prev_addr + $::Objects{$prev_addr}->{'size'} - 1;
|
||
$index++;
|
||
} #end while
|
||
if ($overlap_tally) {
|
||
print "Total overlap of $overlap_tally bytes\n";
|
||
}
|
||
}
|
||
|
||
#----------------------------------------------------------------------
|
||
#
|
||
# Evaluate sizes of interobject spacing (fragmentation loss?)
|
||
# Gather the sizes into histograms for analysis
|
||
# This function assumes a sorted list of addresses is present globally
|
||
|
||
sub generate_and_print_unused_memory_histogram() {
|
||
print "\nInterobject spacing (fragmentation waste) Statistics\n";
|
||
if ($::opt_fragment <= 1) {
|
||
print "Statistics are not being gathered. Use '--fragment=10' to get stats\n";
|
||
return;
|
||
}
|
||
print "Ratio of histogram buckets will be a factor of $::opt_fragment\n";
|
||
|
||
my $prev_addr_end = -1;
|
||
my $prev_addr = -1;
|
||
my $index = 0;
|
||
|
||
my @fragment_count;
|
||
my @fragment_tally;
|
||
my $power;
|
||
my $bucket_size;
|
||
|
||
my $max_power = 0;
|
||
|
||
my $tally_sizes = 0;
|
||
|
||
while ($index <= $#::SortedAddresses) {
|
||
my $address = $::SortedAddresses[$index];
|
||
|
||
my $unused = $address - $prev_addr_end;
|
||
|
||
# handle overlaps gracefully
|
||
if ($unused < 0) {
|
||
$unused = 0;
|
||
}
|
||
|
||
$power = 0;
|
||
$bucket_size = 1;
|
||
while ($bucket_size < $unused) {
|
||
$bucket_size *= $::opt_fragment;
|
||
$power++;
|
||
}
|
||
$fragment_count[$power]++;
|
||
$fragment_tally[$power] += $unused;
|
||
if ($power > $max_power) {
|
||
$max_power = $power;
|
||
}
|
||
my $size = $::Objects{$address}->{'size'};
|
||
$tally_sizes += $size;
|
||
$prev_addr_end = $address + $size - 1;
|
||
$index++;
|
||
}
|
||
|
||
|
||
$power = 0;
|
||
$bucket_size = 1;
|
||
print "Basic gap histogram is (max_size:count):\n";
|
||
while ($power <= $max_power) {
|
||
if (! defined $fragment_count[$power]) {
|
||
$fragment_count[$power] = $fragment_tally[$power] = 0;
|
||
}
|
||
printf " %.1f:", $bucket_size;
|
||
print $fragment_count[$power];
|
||
$power++;
|
||
$bucket_size *= $::opt_fragment;
|
||
}
|
||
print "\n";
|
||
|
||
print "Summary gap analysis:\n";
|
||
|
||
$power = 0;
|
||
$bucket_size = 1;
|
||
my $tally = 0;
|
||
my $count = 0;
|
||
while ($power <= $max_power) {
|
||
$count += $fragment_count[$power];
|
||
$tally += $fragment_tally[$power];
|
||
print "$count gaps, totaling $tally bytes, were under ";
|
||
printf "%.1f bytes each", $bucket_size;
|
||
if ($count) {
|
||
printf ", for an average of %.1f bytes per gap", $tally/$count, ;
|
||
}
|
||
print "\n";
|
||
$power++;
|
||
$bucket_size *= $::opt_fragment;
|
||
}
|
||
|
||
print "Total allocation was $tally_sizes bytes, or ";
|
||
printf "%.0f bytes per allocation block\n\n", $tally_sizes/($count+1);
|
||
|
||
}
|
||
|
||
#----------------------------------------------------------------------
|
||
#
|
||
# Now thread the parents and children together by looking through the
|
||
# slots for each object.
|
||
#
|
||
sub create_parent_links(){
|
||
my $min_addr = $::SortedAddresses[0];
|
||
my $max_addr = $::SortedAddresses[ $#::SortedAddresses]; #allow one beyond each object
|
||
$max_addr += $::Objects{$max_addr}->{'size'};
|
||
|
||
print "Viable addresses range from $min_addr to $max_addr for a total of ",
|
||
$max_addr-$min_addr, " bytes\n\n";
|
||
|
||
# Gather stats as we try to convert slots to children
|
||
my $slot_count = 0; # total slots examined
|
||
my $fixed_addr_count = 0; # slots into interiors that were adjusted
|
||
my $parent_child_count = 0; # Number of parent-child links
|
||
my $child_count = 0; # valid slots, discounting sibling twins
|
||
my $child_dup_count = 0; # number of duplicate child pointers
|
||
my $self_pointer_count = 0; # count of discarded self-pointers
|
||
|
||
foreach my $parent (keys %::Objects) {
|
||
# We'll collect a list of this parent object's children
|
||
# by iterating through its slots.
|
||
my @children;
|
||
my %children_hash;
|
||
my $self_pointer = 0;
|
||
|
||
my @slots = @{$::Objects{$parent}->{'slots'}};
|
||
$slot_count += $#slots + 1;
|
||
SLOT: foreach my $child (@slots) {
|
||
|
||
# We only care about pointers that refer to other objects
|
||
if (! defined $::Objects{$child}) {
|
||
# check to see if we are an interior pointer
|
||
|
||
# Punt if we are completely out of range
|
||
next SLOT unless ($max_addr >= $child &&
|
||
$child >= $min_addr);
|
||
|
||
# Do binary search to find object below this address
|
||
my ($min_index, $beyond_index) = (0, $#::SortedAddresses + 1);
|
||
my $test_index;
|
||
while ($min_index !=
|
||
($test_index = int (($beyond_index+$min_index)/2))) {
|
||
if ($child >= $::SortedAddresses[$test_index]) {
|
||
$min_index = $test_index;
|
||
} else {
|
||
$beyond_index = $test_index;
|
||
}
|
||
}
|
||
# See if pointer is within extent of this object
|
||
my $address = $::SortedAddresses[$test_index];
|
||
next SLOT unless ($child <
|
||
$address + $::Objects{$address}->{'size'});
|
||
|
||
# Make adjustment so we point to the actual child precisely
|
||
$child = $address;
|
||
$fixed_addr_count++;
|
||
}
|
||
|
||
if ($child == $parent) {
|
||
$self_pointer_count++;
|
||
next SLOT; # Discard self-pointers
|
||
}
|
||
|
||
# Avoid creating duplicate child-parent links
|
||
if (! defined $children_hash{$child}) {
|
||
$parent_child_count++;
|
||
# Add the parent to the child's list of parents
|
||
my $parents = $::Objects{$child}->{'parents'};
|
||
if (! $parents) {
|
||
$parents = $::Objects{$child}->{'parents'} = [];
|
||
}
|
||
|
||
$parents->[scalar(@$parents)] = $parent;
|
||
|
||
# Add the child to the parent's list of children
|
||
$children_hash{$child} = 1;
|
||
} else {
|
||
$child_dup_count++;
|
||
}
|
||
}
|
||
@children = keys %children_hash;
|
||
# Track tally of unique children linked
|
||
$child_count += $#children + 1;
|
||
|
||
$::Objects{$parent}->{'children'} = \@children;
|
||
|
||
if (! @children) {
|
||
$::Leafs[$#::Leafs + 1] = $parent;
|
||
}
|
||
}
|
||
print "Scanning $#::SortedAddresses objects, we found $parent_child_count parents-to-child connections by chasing $slot_count pointers.\n",
|
||
"This required $fixed_addr_count interior pointer fixups, skipping $child_dup_count duplicate pointers, ",
|
||
"and $self_pointer_count self pointers\nAlso discarded ",
|
||
$slot_count - $parent_child_count -$self_pointer_count - $child_dup_count,
|
||
" out-of-range pointers\n\n";
|
||
}
|
||
|
||
|
||
#----------------------------------------------------------------------
|
||
# For every leaf, if a leaf has only one parent, then sweep the memory
|
||
# cost into the parent from the leaf
|
||
sub sweep_leaf_memory () {
|
||
my $sweep_count = 0;
|
||
my $leaf_counter = 0;
|
||
LEAF: while ($leaf_counter <= $#::Leafs) {
|
||
my $leaf_addr = $::Leafs[$leaf_counter++];
|
||
my $leaf_obj = $::Objects{$leaf_addr};
|
||
my $parents = $leaf_obj->{'parents'};
|
||
|
||
next LEAF if (! defined($parents) || 1 != scalar(@$parents));
|
||
|
||
# We have only one parent, so we'll try to sweep upwards
|
||
my $parent_addr = @$parents[0];
|
||
my $parent_obj = $::Objects{$parent_addr};
|
||
|
||
# watch out for self-pointers
|
||
next LEAF if ($parent_addr == $leaf_addr);
|
||
|
||
if ($::opt_detail) {
|
||
foreach my $obj ($parent_obj, $leaf_obj) {
|
||
if (!defined $obj->{'original_size'}) {
|
||
$obj->{'original_size'} = $obj->{'size'};
|
||
}
|
||
}
|
||
if (defined $leaf_obj->{'sweep_details'}) {
|
||
if (defined $parent_obj->{'sweep_details'}) { # merge details
|
||
foreach my $swept_obj (keys (%{$leaf_obj->{'sweep_details'}})) {
|
||
%{$parent_obj->{'sweep_details'}}->{$swept_obj} =
|
||
%{$leaf_obj->{'sweep_details'}}->{$swept_obj};
|
||
}
|
||
} else { # No parent info
|
||
$parent_obj->{'sweep_details'} = \%{$leaf_obj->{'sweep_details'}};
|
||
}
|
||
delete $leaf_obj->{'sweep_details'};
|
||
} else { # no leaf detail
|
||
if (!defined $parent_obj->{'sweep_details'}) {
|
||
$parent_obj->{'sweep_details'} = {};
|
||
}
|
||
}
|
||
%{$parent_obj->{'sweep_details'}}->{$leaf_addr} = $leaf_obj->{'original_size'};
|
||
}
|
||
|
||
$parent_obj->{'size'} += $leaf_obj->{'size'};
|
||
$leaf_obj->{'size'} = 0;
|
||
|
||
if (defined ($leaf_obj->{'swept_in'})) {
|
||
$parent_obj->{'swept_in'} += $leaf_obj->{'swept_in'};
|
||
$leaf_obj->{'swept_in'} = 0; # sweep has been handed off to parent
|
||
}
|
||
$parent_obj->{'swept_in'} ++; # tally swept in leaf_obj
|
||
|
||
$sweep_count++;
|
||
|
||
# See if we created another leaf
|
||
my $consumed_children = $parent_obj->{'consumed'}++;
|
||
my @children = $parent_obj->{'children'};
|
||
if ($consumed_children == $#children) {
|
||
$::Leafs[$#::Leafs + 1] = @$parents[0];
|
||
}
|
||
}
|
||
print "Processed ", $leaf_counter, " leaves sweeping memory to parents in ", $sweep_count, " objects\n";
|
||
}
|
||
|
||
|
||
#----------------------------------------------------------------------
|
||
#
|
||
# Subdivide the types of objects that are in our "expand" list
|
||
# List types that should be sub-divided based on parents, and possibly
|
||
# children
|
||
# The argument supplied is a hash table with keys selecting types that
|
||
# need to be "refined" by including the types of the parent objects,
|
||
# and (when we are desparate) the types of the children objects.
|
||
|
||
sub expand_type_names($) {
|
||
my %TypeExpand = %{$_[0]};
|
||
|
||
my @retype; # array of addrs that get extended type names
|
||
foreach my $child (keys %::Objects) {
|
||
my $child_obj = $::Objects{$child};
|
||
next unless (defined ($TypeExpand{$child_obj->{'type'}}));
|
||
|
||
foreach my $relation ('parents','children') {
|
||
my $relatives = $child_obj->{$relation};
|
||
next unless defined @$relatives;
|
||
|
||
# Sort out the names of the types of the relatives
|
||
my %names;
|
||
foreach my $relative (@$relatives) {
|
||
%names->{$::Objects{$relative}->{'type'}} = 1;
|
||
}
|
||
my $related_type_names = join(',' , sort(keys(%names)));
|
||
|
||
|
||
$child_obj->{'name' . $relation} = $related_type_names;
|
||
|
||
# Don't bother with children if we have significant parent types
|
||
last if (!defined ($TypeExpand{$related_type_names}));
|
||
}
|
||
$retype[$#retype + 1] = $child;
|
||
}
|
||
|
||
# Revisit all addresses we've marked
|
||
foreach my $child (@retype) {
|
||
my $child_obj = $::Objects{$child};
|
||
$child_obj->{'type'} = $TypeExpand{$child_obj->{'type'}};
|
||
my $extended_type = $child_obj->{'namechildren'};
|
||
if (defined $extended_type) {
|
||
$child_obj->{'type'}.= "->(" . $extended_type . ")";
|
||
delete ($child_obj->{'namechildren'});
|
||
}
|
||
$extended_type = $child_obj->{'nameparents'};
|
||
if (defined $extended_type) {
|
||
$child_obj->{'type'} = "(" . $extended_type . ")->" . $::Objects{$child}->{'type'};
|
||
delete ($child_obj->{'nameparents'});
|
||
}
|
||
}
|
||
}
|
||
|
||
#----------------------------------------------------------------------
|
||
#
|
||
# Print out a type histogram
|
||
|
||
sub print_type_histogram() {
|
||
load_type_table();
|
||
print_type_table();
|
||
print "\n\n";
|
||
}
|
||
|
||
|
||
#----------------------------------------------------------------------
|
||
# Provide a nice summary of the types during the process
|
||
validate_address_ranges();
|
||
create_parent_links();
|
||
|
||
print "\nBasic memory use histogram is:\n";
|
||
print_type_histogram();
|
||
|
||
generate_and_print_unused_memory_histogram();
|
||
|
||
sweep_leaf_memory ();
|
||
print "After doing basic leaf-sweep processing of instances:\n";
|
||
print_type_histogram();
|
||
|
||
{
|
||
foreach my $typename (@::opt_typedivide) {
|
||
my %expansion_table;
|
||
$expansion_table{$typename} = $typename;
|
||
expand_type_names(\%expansion_table);
|
||
print "After subdividing <$typename> based on inbound (and somtimes outbound) pointers:\n";
|
||
print_type_histogram();
|
||
}
|
||
}
|
||
|
||
exit(); # Don't bother with SCCs yet.
|
||
|
||
|
||
#----------------------------------------------------------------------
|
||
#
|
||
# Determine objects that entrain equivalent sets, using the strongly
|
||
# connected component algorithm from Cormen, Leiserson, and Rivest,
|
||
# ``An Introduction to Algorithms'', MIT Press 1990, pp. 488-493.
|
||
#
|
||
sub compute_post_order($$$) {
|
||
# This routine produces a post-order of the call graph (what CLR call
|
||
# ``ordering the nodes by f[u]'')
|
||
my ($parent, $visited, $finish) = @_;
|
||
|
||
# Bail if we've already seen this node
|
||
return if $visited->{$parent};
|
||
|
||
# We have now!
|
||
$visited->{$parent} = 1;
|
||
|
||
# Walk the children
|
||
my $children = $::Objects{$parent}->{'children'};
|
||
|
||
foreach my $child (@$children) {
|
||
compute_post_order($child, $visited, $finish);
|
||
}
|
||
|
||
# Now that we've walked all the kids, we can append the parent to
|
||
# the post-order
|
||
@$finish[scalar(@$finish)] = $parent;
|
||
}
|
||
|
||
sub compute_equivalencies($$$) {
|
||
# This routine recursively computes equivalencies by walking the
|
||
# transpose of the callgraph.
|
||
my ($child, $table, $equivalencies) = @_;
|
||
|
||
# Bail if we've already seen this node
|
||
return if $table->{$child};
|
||
|
||
# Otherwise, append ourself to the list of equivalencies...
|
||
@$equivalencies[scalar(@$equivalencies)] = $child;
|
||
|
||
# ...and note our other equivalents in the table
|
||
$table->{$child} = $equivalencies;
|
||
|
||
my $parents = $::Objects{$child}->{'parents'};
|
||
|
||
foreach my $parent (@$parents) {
|
||
compute_equivalencies($parent, $table, $equivalencies);
|
||
}
|
||
}
|
||
|
||
sub compute_equivalents() {
|
||
# Here's the strongly connected components algorithm. (Step 2 has been
|
||
# done implictly by our object graph construction.)
|
||
my %visited;
|
||
my @finish;
|
||
|
||
# Step 1. Compute a post-ordering of the object graph
|
||
foreach my $parent (keys %::Objects) {
|
||
compute_post_order($parent, \%visited, \@finish);
|
||
}
|
||
|
||
# Step 3. Traverse the transpose of the object graph in reverse
|
||
# post-order, collecting vertices into %equivalents
|
||
my %equivalents;
|
||
foreach my $child (reverse @finish) {
|
||
compute_equivalencies($child, \%equivalents, []);
|
||
}
|
||
|
||
# Now, we'll trim the %equivalents table, arbitrarily removing
|
||
# ``redundant'' entries.
|
||
EQUIVALENT: foreach my $node (keys %equivalents) {
|
||
my $equivalencies = $equivalents{$node};
|
||
next EQUIVALENT unless $equivalencies;
|
||
|
||
foreach my $equivalent (@$equivalencies) {
|
||
delete $equivalents{$equivalent} unless $equivalent == $node;
|
||
}
|
||
}
|
||
|
||
# Note the equivalent objects in a way that will yield the most
|
||
# interesting order as we do depth-first traversal later to
|
||
# output them.
|
||
ROOT: foreach my $equivalent (reverse @finish) {
|
||
next ROOT unless $equivalents{$equivalent};
|
||
$::Equivalents[$#::Equivalents + 1] = $equivalent;
|
||
|
||
# XXX Lame! Should figure out function refs.
|
||
$::Objects{$equivalent}->{'entrained-size'} = 0;
|
||
}
|
||
}
|
||
|
||
# Do it!
|
||
compute_equivalents();
|
||
|
||
|
||
#----------------------------------------------------------------------
|
||
#
|
||
# Compute the size of each node's transitive closure.
|
||
#
|
||
sub compute_entrained($$) {
|
||
my ($parent, $visited) = @_;
|
||
|
||
$visited->{$parent} = 1;
|
||
|
||
$::Objects{$parent}->{'entrained-size'} = $::Objects{$parent}->{'size'};
|
||
|
||
my $children = $::Objects{$parent}->{'children'};
|
||
CHILD: foreach my $child (@$children) {
|
||
next CHILD if $visited->{$child};
|
||
|
||
compute_entrained($child, $visited);
|
||
$::Objects{$parent}->{'entrained-size'} += $::Objects{$child}->{'entrained-size'};
|
||
}
|
||
}
|
||
|
||
if (! $::opt_noentrained) {
|
||
my %visited;
|
||
|
||
PARENT: foreach my $parent (@::Equivalents) {
|
||
next PARENT if $visited{$parent};
|
||
compute_entrained($parent, \%visited);
|
||
}
|
||
}
|
||
|
||
|
||
#----------------------------------------------------------------------
|
||
#
|
||
# Converts a shared library and an address into a file and line number
|
||
# using a bunch of addr2line processes.
|
||
#
|
||
sub addr2line($$) {
|
||
my ($dso, $addr) = @_;
|
||
|
||
# $::Addr2Lines is a global table that maps a DSO's name to a pair
|
||
# of filehandles that are talking to an addr2line process.
|
||
my $fhs = $::Addr2Lines{$dso};
|
||
if (! $fhs) {
|
||
if (!(-r $dso)) {
|
||
# bogus filename (that happens sometimes), so bail
|
||
return { 'dso' => $dso, 'addr' => $addr };
|
||
}
|
||
my ($in, $out) = (new FileHandle, new FileHandle);
|
||
open2($in, $out, "addr2line --exe=$dso") || die "unable to open addr2line --exe=$dso";
|
||
$::Addr2Lines{$dso} = $fhs = { 'in' => $in, 'out' => $out };
|
||
}
|
||
|
||
# addr2line takes a hex address as input...
|
||
$fhs->{'out'}->print($addr . "\n");
|
||
|
||
# ...and'll return file:lineno as output
|
||
if ($fhs->{'in'}->getline() =~ /([^:]+):(.+)/) {
|
||
return { 'file' => $1, 'line' => $2 };
|
||
}
|
||
else {
|
||
return { 'dso' => $dso, 'addr' => $addr };
|
||
}
|
||
}
|
||
|
||
|
||
#----------------------------------------------------------------------
|
||
#
|
||
# Dump the objects, using a depth-first traversal.
|
||
#
|
||
sub dump_objects($$$) {
|
||
my ($parent, $visited, $depth) = @_;
|
||
|
||
# Have we already seen this?
|
||
my $already_visited = $visited->{$parent};
|
||
return if ($depth == 0 && $already_visited);
|
||
|
||
if (! $already_visited) {
|
||
$visited->{$parent} = 1;
|
||
$::Total += $::Objects{$parent}->{'size'};
|
||
}
|
||
|
||
my $parententry = $::Objects{$parent};
|
||
|
||
# Make an ``object'' div, which'll contain an ``object'' span, two
|
||
# ``toggle'' spans, an invisible ``stack'' div, and the invisible
|
||
# ``children'' div.
|
||
print "<div class='object'>";
|
||
|
||
if ($already_visited) {
|
||
print "<a href='#$parent'>";
|
||
}
|
||
else {
|
||
print "<span id='$parent' class='object";
|
||
print " root" if $depth == 0;
|
||
print "'>";
|
||
}
|
||
|
||
printf "0x%x<%s>[%d]", $parent, $parententry->{'type'}, $parententry->{'size'};
|
||
|
||
if ($already_visited) {
|
||
print "</a>";
|
||
goto DONE;
|
||
}
|
||
|
||
if ($depth == 0) {
|
||
print "($parententry->{'entrained-size'})"
|
||
if $parententry->{'entrained-size'};
|
||
|
||
print " <span class='toggle' onclick='toggleDisplay(this.parentNode.nextSibling.nextSibling);'>Children</span>"
|
||
if @{$parententry->{'children'}} > 0;
|
||
}
|
||
|
||
if (($depth == 0 || !$::opt_nochildstacks) && !$::opt_nostacks) {
|
||
print " <span class='toggle' onclick='toggleDisplay(this.parentNode.nextSibling);'>Stack</span>";
|
||
}
|
||
|
||
print "</span>";
|
||
|
||
# Print stack traces
|
||
print "<div class='stack'>\n";
|
||
|
||
if (($depth == 0 || !$::opt_nochildstacks) && !$::opt_nostacks) {
|
||
my $depth = $::opt_depth;
|
||
|
||
FRAME: foreach my $frame (@{$parententry->{'stack'}}) {
|
||
# Only go as deep as they've asked us to.
|
||
last FRAME unless --$depth >= 0;
|
||
|
||
# Stack frames look like ``mangled_name[dso address]''
|
||
$frame =~ /([^\]]+)\[(.*) \+0x([0-9A-Fa-f]+)\]/;
|
||
|
||
# Convert address to file and line number
|
||
my $mangled = $1;
|
||
my $result = addr2line($2, $3);
|
||
|
||
if ($result->{'file'}) {
|
||
# It's mozilla source! Clean up refs to dist/include
|
||
if (($result->{'file'} =~ s/.*\.\.\/\.\.\/dist\/include\//http:\/\/bonsai.mozilla.org\/cvsguess.cgi\?file=/) ||
|
||
($result->{'file'} =~ s/.*\/mozilla/http:\/\/bonsai.mozilla.org\/cvsblame.cgi\?file=mozilla/)) {
|
||
my $prevline = $result->{'line'} - 10;
|
||
print "<a target=\"lxr_source\" href=\"$result->{'file'}\&mark=$result->{'line'}#$prevline\">$mangled</a><br>\n";
|
||
}
|
||
else {
|
||
print "$mangled ($result->{'file'}, line $result->{'line'})<br>\n";
|
||
}
|
||
}
|
||
else {
|
||
print "$result->{'dso'} ($result->{'addr'})<br>\n";
|
||
}
|
||
}
|
||
|
||
}
|
||
|
||
print "</div>";
|
||
|
||
# Recurse to children
|
||
if (@{$parententry->{'children'}} >= 0) {
|
||
print "<div class='children'>\n" if $depth == 0;
|
||
|
||
foreach my $child (@{$parententry->{'children'}}) {
|
||
dump_objects($child, $visited, $depth + 1);
|
||
}
|
||
|
||
print "</div>" if $depth == 0;
|
||
}
|
||
|
||
DONE:
|
||
print "</div>\n";
|
||
}
|
||
|
||
|
||
#----------------------------------------------------------------------
|
||
#
|
||
# Do the output.
|
||
#
|
||
|
||
# Force flush on STDOUT. We get funky output unless we do this.
|
||
$| = 1;
|
||
|
||
# Header
|
||
print "<html>
|
||
<head>
|
||
<title>Object Graph</title>
|
||
<style type='text/css'>
|
||
body { font: medium monospace; background-color: white; }
|
||
|
||
/* give nested div's some margins to make it look like a tree */
|
||
div.children > div.object { margin-left: 1em; }
|
||
div.object > div.object { margin-left: 1em; }
|
||
|
||
/* Indent stacks, too */
|
||
div.object > div.stack { margin-left: 3em; }
|
||
|
||
/* apply font decorations to special ``object'' spans */
|
||
span.object { font-weight: bold; color: darkgrey; }
|
||
span.object.root { color: black; }
|
||
|
||
/* hide ``stack'' divs by default; JS will show them */
|
||
div.stack { display: none; }
|
||
|
||
/* hide ``children'' divs by default; JS will show them */
|
||
div.children { display: none; }
|
||
|
||
/* make ``toggle'' spans look like links */
|
||
span.toggle { color: blue; text-decoration: underline; cursor: pointer; }
|
||
span.toggle:active { color: red; }
|
||
</style>
|
||
<script language='JavaScript'>
|
||
function toggleDisplay(element)
|
||
{
|
||
element.style.display = (element.style.display == 'block') ? 'none' : 'block';
|
||
}
|
||
</script>
|
||
</head>
|
||
<body>
|
||
";
|
||
|
||
{
|
||
# Body. Display ``roots'', sorted by the amount of memory they
|
||
# entrain. Because of the way we've sorted @::Equivalents, we should
|
||
# get a nice ordering that sorts things with a lot of kids early
|
||
# on. This should yield a fairly "deep" depth-first traversal, with
|
||
# most of the objects appearing as children.
|
||
#
|
||
# XXX I sure hope that Perl implements a stable sort!
|
||
my %visited;
|
||
|
||
foreach my $parent (sort { $::Objects{$b}->{'entrained-size'}
|
||
<=> $::Objects{$a}->{'entrained-size'} }
|
||
@::Equivalents) {
|
||
dump_objects($parent, \%visited, 0);
|
||
print "\n";
|
||
}
|
||
}
|
||
|
||
# Footer
|
||
print "<br> $::Total total bytes\n" if $::Total;
|
||
print "</body>
|
||
</html>
|
||
";
|
||
|