gecko/tools/trace-malloc/leak-soup.pl

1216 lines
38 KiB
Perl
Executable File
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

#!/usr/bin/perl -w
#
# ***** BEGIN LICENSE BLOCK *****
# Version: MPL 1.1/GPL 2.0/LGPL 2.1
#
# The contents of this file are subject to the Mozilla Public License Version
# 1.1 (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.mozilla.org/MPL/
#
# Software distributed under the License is distributed on an "AS IS" basis,
# WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
# for the specific language governing rights and limitations under the
# License.
#
# The Original Code is leak-soup.pl, released
# Oct 1, 2000.
#
# The Initial Developer of the Original Code is
# Netscape Communications Corporation.
# Portions created by the Initial Developer are Copyright (C) 2000
# the Initial Developer. All Rights Reserved.
#
# Contributor(s):
# Chris Waterson <waterson@netscape.com>
# Jim Roskind <jar@netscape.com>
#
# Alternatively, the contents of this file may be used under the terms of
# either the GNU General Public License Version 2 or later (the "GPL"), or
# the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
# in which case the provisions of the GPL or the LGPL are applicable instead
# of those above. If you wish to allow use of your version of this file only
# under the terms of either the GPL or the LGPL, and not to allow others to
# use your version of this file under the terms of the MPL, indicate your
# decision by deleting the provisions above and replace them with the notice
# and other provisions required by the GPL or the LGPL. If you do not delete
# the provisions above, a recipient may use your version of this file under
# the terms of any one of the MPL, the GPL or the LGPL.
#
# ***** END LICENSE BLOCK *****
# 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&lt;%s&gt;[%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 "&nbsp;<span class='toggle' onclick='toggleDisplay(this.parentNode.nextSibling.nextSibling);'>Children</span>"
if @{$parententry->{'children'}} > 0;
}
if (($depth == 0 || !$::opt_nochildstacks) && !$::opt_nostacks) {
print "&nbsp;<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>
";