1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/tools/trace-malloc/leak-soup.pl Wed Dec 31 06:09:35 2014 +0100
1.3 @@ -0,0 +1,1180 @@
1.4 +#!/usr/bin/perl -w
1.5 +#
1.6 +# This Source Code Form is subject to the terms of the Mozilla Public
1.7 +# License, v. 2.0. If a copy of the MPL was not distributed with this
1.8 +# file, You can obtain one at http://mozilla.org/MPL/2.0/.
1.9 +
1.10 +# A perl version of Patrick Beard's ``Leak Soup'', which processes the
1.11 +# stack crawls from the Boehm GC into a graph.
1.12 +
1.13 +use 5.004;
1.14 +use strict;
1.15 +use Getopt::Long;
1.16 +use FileHandle;
1.17 +use IPC::Open2;
1.18 +
1.19 +# Collect program options
1.20 +$::opt_help = 0;
1.21 +$::opt_detail = 0;
1.22 +$::opt_fragment = 1.0; # Default to no fragment analysis
1.23 +$::opt_nostacks = 0;
1.24 +$::opt_nochildstacks = 0;
1.25 +$::opt_depth = 9999;
1.26 +$::opt_noentrained = 0;
1.27 +$::opt_noslop = 0;
1.28 +$::opt_showtype = -1; # default to listing all types
1.29 +$::opt_stackrefine = "C";
1.30 +@::opt_stackretype = ();
1.31 +@::opt_stackskipclass = ();
1.32 +@::opt_stackskipfunc = ();
1.33 +@::opt_typedivide = ();
1.34 +
1.35 +GetOptions("help", "detail", "format=s", "fragment=f", "nostacks",
1.36 + "nochildstacks", "depth=i", "noentrained", "noslop", "showtype=i",
1.37 + "stackrefine=s", "stackretype=s@", "stackskipclass=s@", "stackskipfunc=s@",
1.38 + "typedivide=s@"
1.39 + );
1.40 +
1.41 +if ($::opt_help) {
1.42 + die "usage: leak-soup.pl [options] <leakfile>
1.43 + --help Display this message
1.44 + --detail Provide details of memory sweeping from child to parents
1.45 + --fragment=ratio Histogram bucket ratio for fragmentation analysis
1.46 +# --nostacks Do not compute stack traces
1.47 +# --nochildstacks Do not compute stack traces for entrained objects
1.48 +# --depth=<max> Only compute stack traces to depth of <max>
1.49 +# --noentrained Do not compute amount of memory entrained by root objects
1.50 + --noslop Don't ignore low bits when searching for pointers
1.51 + --showtype=<i> Show memory usage histogram for most-significant <i> types
1.52 + --stackrefine={F|C} During stack based refinement, use 'F'ull name name or just 'C'lass
1.53 + --stackretype=type Use allocation stack to refine vague types like void*
1.54 + --stackskipclass=class When refining types, ignore stack frames from 'class'
1.55 + --stackskipfunc=func When refining types, ignore stack frames for 'func'
1.56 + --typedivide=type Subdivide 'type' based on objects pointing to each instance
1.57 +";
1.58 +}
1.59 +
1.60 +# This is the table that keeps a graph of objects. It's indexed by the
1.61 +# object's address (as an integer), and refers to a simple hash that
1.62 +# has information about the object's type, size, slots, and allocation
1.63 +# stack.
1.64 +%::Objects = %{0};
1.65 +
1.66 +# This will be a list of keys to (addresses in) Objects, that is sorted
1.67 +# It gets used to evaluate overlaps, calculate fragmentation, and chase
1.68 +# parent->child (interior) pointers.
1.69 +@::SortedAddresses = [];
1.70 +
1.71 +# This is the table that keeps track of memory usage on a per-type basis.
1.72 +# It is indexed by the type name (string), and keeps a tally of the
1.73 +# total number of such objects, and the memory usage of such objects.
1.74 +%::Types = %{0};
1.75 +$::TotalSize = 0; # sum of sizes of all objects included $::Types{}
1.76 +
1.77 +# This is an array of leaf node addresses. A leaf node has no children
1.78 +# with memory allocations. We traverse them sweeping memory
1.79 +# tallies into parents. Note that after all children have
1.80 +# been swept into a parent, that parent may also become a leaf node.
1.81 +@::Leafs = @{0};
1.82 +
1.83 +
1.84 +
1.85 +
1.86 +#----------------------------------------------------------------------
1.87 +#
1.88 +# Decode arguments to override default values for doing call-stack-based
1.89 +# refinement of typename based on contents of the stack at allocation time.
1.90 +#
1.91 +
1.92 +# List the types that we need to refine (if any) based on allocation stack
1.93 +$::VagueType = {
1.94 + 'void*' => 1,
1.95 +};
1.96 +
1.97 +# With regard to the stack, ignore stack frames in the following
1.98 +# overly vague classes.
1.99 +$::VagueClasses = {
1.100 +# 'nsStr' => 1,
1.101 + 'nsVoidArray' => 1,
1.102 +};
1.103 +
1.104 +# With regard to stack, ignore stack frames with the following vague
1.105 +# function names
1.106 +$::VagueFunctions = {
1.107 + 'PL_ArenaAllocate' => 1,
1.108 + 'PL_HashTableFinalize(PLHashTable *)' => 1,
1.109 + 'PL_HashTableInit__FP11PLHashTableUiPFPCv_UiPFPCvPCv_iT3PC14PLHashAllocOpsPv' => 1,
1.110 + 'PL_HashTableRawAdd' => 1,
1.111 + '__builtin_vec_new' => 1,
1.112 + '_init' => 1,
1.113 + 'il_get_container(_IL_GroupContext *, ImgCachePolicy, char const *, _NI_IRGB *, IL_DitherMode, int, int, int)' => 1,
1.114 + 'nsCStringKey::Clone(void) const' => 1,
1.115 + 'nsCppSharedAllocator<unsigned short>::allocate(unsigned int, void const *)' => 1,
1.116 + 'nsHashtable::Put(nsHashKey *, void *)' => 1,
1.117 + 'nsHashtable::nsHashtable(unsigned int, int)' => 1,
1.118 + 'nsMemory::Alloc(unsigned int)' => 1,
1.119 + 'nsMemoryImpl::Alloc(unsigned int)' => 1,
1.120 +};
1.121 +
1.122 +sub init_stack_based_type_refinement() {
1.123 + # Move across stackretype options, or use default values
1.124 + if ($#::opt_stackretype < 0) {
1.125 + print "Default --stackretype options will be used (since none were specified)\n";
1.126 + print " use --stackretype='nothing' to disable re-typing activity\n";
1.127 + } else {
1.128 + foreach my $type (keys %{$::VagueType}) {
1.129 + delete ($::VagueType->{$type});
1.130 + }
1.131 + if ($#::opt_stackretype == 0 && $::opt_stackretype[0] eq 'nothing') {
1.132 + print "Types will not be refined based on call stack\n";
1.133 + } else {
1.134 + foreach my $type (@::opt_stackretype) {
1.135 + $::VagueType->{$type} = 1;
1.136 + }
1.137 + }
1.138 + }
1.139 +
1.140 +
1.141 + if (keys %{$::VagueType}) {
1.142 + print "The following type(s) will be refined based on call stacks:\n";
1.143 + foreach my $type (sort keys %{$::VagueType}) {
1.144 + print " $type\n";
1.145 + }
1.146 + print "Equivalent command line argument(s):\n";
1.147 + foreach my $type (sort keys %{$::VagueType}) {
1.148 + print " --stackretype='$type'";
1.149 + }
1.150 + print "\n\n";
1.151 +
1.152 + if ($#::opt_stackskipclass < 0) {
1.153 + print "Default --stackskipclass options will be used (since none were specified)\n";
1.154 + print " use --stackskipclass='nothing' to disable skipping stack frames based on class names\n";
1.155 + } else {
1.156 + foreach my $type (keys %{$::VagueClasses}) {
1.157 + delete ($::VagueClasses->{$type});
1.158 + }
1.159 + if ($#::opt_stackskipclass == 0 && $::opt_stackskipclass[0] eq 'nothing') {
1.160 + print "Types will not be refined based on call stack\n";
1.161 + } else {
1.162 + foreach my $type (@::opt_stackskipclass) {
1.163 + $::VagueClasses->{$type} = 1;
1.164 + }
1.165 + }
1.166 + }
1.167 +
1.168 + if (keys %{$::VagueClasses}) {
1.169 + print "Stack frames from the following class(es) will not be used to refine types:\n";
1.170 + foreach my $class (sort keys %{$::VagueClasses}) {
1.171 + print " $class\n";
1.172 + }
1.173 + print "Equivalent command line argument(s):\n";
1.174 + foreach my $class (sort keys %{$::VagueClasses}) {
1.175 + print " --stackskipclass='$class'";
1.176 + }
1.177 + print "\n\n";
1.178 + }
1.179 +
1.180 +
1.181 + if ($#::opt_stackskipfunc < 0) {
1.182 + print "Default --stackskipfunc options will be used (since none were specified)\n";
1.183 + print " use --stackskipfunc='nothing' to disable skipping stack frames based on function names\n";
1.184 + } else {
1.185 + foreach my $type (keys %{$::VagueFunctions}) {
1.186 + delete ($::VagueFunctions->{$type});
1.187 + }
1.188 + if ($#::opt_stackskipfunc == 0 && $::opt_stackskipfunc[0] eq 'nothing') {
1.189 + print "Types will not be refined based on call stack\n";
1.190 + } else {
1.191 + foreach my $type (@::opt_stackskipfunc) {
1.192 + $::VagueFunctions->{$type} = 1;
1.193 + }
1.194 + }
1.195 + }
1.196 +
1.197 + if (keys %{$::VagueFunctions}) {
1.198 + print "Stack frames from the following function(s) will not be used to refine types:\n";
1.199 + foreach my $func (sort keys %{$::VagueFunctions}) {
1.200 + print " $func\n";
1.201 + }
1.202 + print "Equivalent command line argument(s):\n";
1.203 + foreach my $func (sort keys %{$::VagueFunctions}) {
1.204 + print " --stackskipfunc='$func'";
1.205 + }
1.206 + print "\n\n";
1.207 + }
1.208 + }
1.209 +}
1.210 +
1.211 +
1.212 +#----------------------------------------------------------------------
1.213 +#
1.214 +# Read in the output from the Boehm GC or Trace-malloc.
1.215 +#
1.216 +sub read_boehm() {
1.217 + OBJECT: while (<>) {
1.218 + # e.g., 0x0832FBD0 <void*> (80)
1.219 + next OBJECT unless /^0x(\S+) <(.*)> \((\d+)\)/;
1.220 + my ($addr, $type, $size) = (hex $1, $2, $3);
1.221 +
1.222 + my $object = $::Objects{$addr};
1.223 + if (! $object) {
1.224 + # Found a new object entry. Record its type and size
1.225 + $::Objects{$addr} =
1.226 + $object =
1.227 + { 'type' => $type, 'size' => $size };
1.228 + } else {
1.229 + print "Duplicate address $addr contains $object->{'type'} and $type\n";
1.230 + $object->{'dup_addr_count'}++;
1.231 + }
1.232 +
1.233 + # Record the object's slots
1.234 + my @slots;
1.235 +
1.236 + SLOT: while (<>) {
1.237 + # e.g., 0x00000000
1.238 + last SLOT unless /^\t0x(\S+)/;
1.239 + my $value = hex $1;
1.240 +
1.241 + # Ignore low bits, unless they've specified --noslop
1.242 + $value &= ~0x7 unless $::opt_noslop;
1.243 +
1.244 + $slots[$#slots + 1] = $value;
1.245 + }
1.246 +
1.247 + $object->{'slots'} = \@slots;
1.248 +
1.249 + if (@::opt_stackretype && (defined $::VagueType->{$type})) {
1.250 + # Change the value of type of the object based on stack
1.251 + # if we can find an interesting calling function
1.252 + VAGUEFRAME: while (<>) {
1.253 + # e.g., _dl_debug_message[/lib/ld-linux.so.2 +0x0000B858]
1.254 + last VAGUEFRAMEFRAME unless /^(.*)\[(.*) \+0x(\S+)\]$/;
1.255 + my ($func, $lib, $off) = ($1, $2, hex $3);
1.256 + chomp;
1.257 +
1.258 + my ($class,,$fname) = split(/:/, $func);
1.259 + next VAGUEFRAME if (defined $::VagueFunctions->{$func} ||
1.260 + defined $::VagueClasses->{$class});
1.261 +
1.262 + # Refine typename and exit stack scan
1.263 + $object->{'type'} = $type . ":" .
1.264 + (('C' eq $::opt_stackrefine) ?
1.265 + $class :
1.266 + $func);
1.267 + last VAGUEFRAME;
1.268 + }
1.269 + } else {
1.270 + # Save all stack info if requested
1.271 + if (! $::opt_nostacks) {
1.272 + # Record the stack by which the object was allocated
1.273 + my @stack;
1.274 +
1.275 + FRAME: while (<>) {
1.276 + # e.g., _dl_debug_message[/lib/ld-linux.so.2 +0x0000B858]
1.277 + last FRAME unless /^(.*)\[(.*) \+0x(\S+)\]$/;
1.278 + my ($func, $lib, $off) = ($1, $2, hex $3);
1.279 + chomp;
1.280 +
1.281 + $stack[$#stack + 1] = $_;
1.282 + }
1.283 +
1.284 + $object->{'stack'} = \@stack;
1.285 + }
1.286 + }
1.287 +
1.288 + # Gotta check EOF explicitly...
1.289 + last OBJECT if eof;
1.290 + }
1.291 +}
1.292 +
1.293 +
1.294 +#----------------------------------------------------------------------
1.295 +#
1.296 +# Read input
1.297 +#
1.298 +init_stack_based_type_refinement();
1.299 +read_boehm;
1.300 +
1.301 +
1.302 +
1.303 +#----------------------------------------------------------------------
1.304 +#
1.305 +# Do basic initialization of the type hash table. Accumulate
1.306 +# total counts, and basic memory usage (not including children)
1.307 +sub load_type_table() {
1.308 + # Reset global counter and hash table
1.309 + $::TotalSize = 0;
1.310 + %::Types = %{0};
1.311 +
1.312 + OBJECT: foreach my $addr (keys %::Objects) {
1.313 + my $obj = $::Objects{$addr};
1.314 + my ($type, $size, $swept_in, $overlap_count, $dup_addr_count) =
1.315 + ($obj->{'type'}, $obj->{'size'},
1.316 + $obj->{'swept_in'},
1.317 + $obj->{'overlap_count'},$obj->{'dup_addr_count'});
1.318 +
1.319 + my $type_data = $::Types{$type};
1.320 + if (! defined $type_data) {
1.321 + $::Types{$type} =
1.322 + $type_data = {'count' => 0, 'size' => 0,
1.323 + 'max' => $size, 'min' => $size,
1.324 + 'swept_in' => 0, 'swept' => 0,
1.325 + 'overlap_count' => 0,
1.326 + 'dup_addr_count' => 0};
1.327 + }
1.328 +
1.329 + if (!$size) {
1.330 + $type_data->{'swept'}++;
1.331 + next OBJECT;
1.332 + }
1.333 + $::TotalSize += $size;
1.334 +
1.335 + $type_data->{'count'}++;
1.336 + $type_data->{'size'} += $size;
1.337 + if (defined $swept_in) {
1.338 + $type_data->{'swept_in'} += $swept_in;
1.339 +
1.340 + if ($::opt_detail) {
1.341 + my $type_detail_sizes = $type_data->{'sweep_details_size'};
1.342 + my $type_detail_counts;
1.343 + if (!defined $type_detail_sizes) {
1.344 + $type_detail_sizes = $type_data->{'sweep_details_size'} = {};
1.345 + $type_detail_counts = $type_data->{'sweep_details_count'} = {};
1.346 + } else {
1.347 + $type_detail_counts = $type_data->{'sweep_details_count'};
1.348 + }
1.349 +
1.350 + my $sweep_details = $obj->{'sweep_details'};
1.351 + for my $swept_addr (keys (%{$sweep_details})) {
1.352 + my $swept_obj = $::Objects{$swept_addr};
1.353 + my $swept_type = $swept_obj->{'type'};
1.354 + $type_detail_sizes->{$swept_type} += $sweep_details->{$swept_addr};
1.355 + $type_detail_counts->{$swept_type}++;
1.356 + }
1.357 + }
1.358 + }
1.359 + if (defined $overlap_count) {
1.360 + $type_data->{'overlap_count'} += $overlap_count;
1.361 + }
1.362 +
1.363 + if (defined $dup_addr_count) {
1.364 + $type_data->{'dup_addr_count'} += $dup_addr_count;
1.365 + }
1.366 +
1.367 + if ($type_data->{'max'} < $size) {
1.368 + $type_data->{'max'} = $size;
1.369 + }
1.370 + # Watch out for case where min is produced by a swept object
1.371 + if (!$type_data->{'min'} || $type_data->{'min'} > $size) {
1.372 + $type_data->{'min'} = $size;
1.373 + }
1.374 + }
1.375 +}
1.376 +
1.377 +
1.378 +#----------------------------------------------------------------------
1.379 +sub print_type_table(){
1.380 + if (!$::opt_showtype) {
1.381 + return;
1.382 + }
1.383 + my $line_count = 0;
1.384 + my $bytes_printed_tally = 0;
1.385 +
1.386 + # Display type summary information
1.387 + my @sorted_types = keys (%::Types);
1.388 + print "There are ", 1 + $#sorted_types, " types containing ", $::TotalSize, " bytes\n";
1.389 + @sorted_types = sort {$::Types{$b}->{'size'}
1.390 + <=> $::Types{$a}->{'size'} } @sorted_types;
1.391 +
1.392 + foreach my $type (@sorted_types) {
1.393 + last if ($line_count++ == $::opt_showtype);
1.394 +
1.395 + my $type_data = $::Types{$type};
1.396 + $bytes_printed_tally += $type_data->{'size'};
1.397 +
1.398 + if ($type_data->{'count'}) {
1.399 + printf "%.2f%% ", $type_data->{'size'} * 100.0/$::TotalSize;
1.400 + print $type_data->{'size'},
1.401 + "\t(",
1.402 + $type_data->{'min'}, "/",
1.403 + int($type_data->{'size'} / $type_data->{'count'}),"/",
1.404 + $type_data->{'max'}, ")";
1.405 + print "\t", $type_data->{'count'},
1.406 + " x ";
1.407 + }
1.408 + print $type;
1.409 +
1.410 + if ($type_data->{'swept_in'}) {
1.411 + print ", $type_data->{'swept_in'} sub-objs absorbed";
1.412 + }
1.413 + if ($type_data->{'swept'}) {
1.414 + print ", $type_data->{'swept'} swept away";
1.415 + }
1.416 + if ($type_data->{'overlap_count'}) {
1.417 + print ", $type_data->{'overlap_count'} range overlaps";
1.418 + }
1.419 + if ($type_data->{'dup_addr_count'}) {
1.420 + print ", $type_data->{'dup_addr_count'} duplicated addresses";
1.421 + }
1.422 +
1.423 + print "\n" ;
1.424 + if (defined $type_data->{'sweep_details_size'}) {
1.425 + my $sizes = $type_data->{'sweep_details_size'};
1.426 + my $counts = $type_data->{'sweep_details_count'};
1.427 + my @swept_types = sort {$sizes->{$b} <=> $sizes->{$a}} keys (%{$sizes});
1.428 +
1.429 + for my $type (@swept_types) {
1.430 + printf " %.2f%% ", $sizes->{$type} * 100.0/$::TotalSize;
1.431 + print "$sizes->{$type} (", int($sizes->{$type}/$counts->{$type}) , ") $counts->{$type} x $type\n";
1.432 + }
1.433 + print " ---------------\n";
1.434 + }
1.435 + }
1.436 + if ($bytes_printed_tally != $::TotalSize) {
1.437 + printf "%.2f%% ", ($::TotalSize- $bytes_printed_tally) * 100.0/$::TotalSize;
1.438 + print $::TotalSize - $bytes_printed_tally, "\t not shown due to truncation of type list\n";
1.439 + print "Currently only data on $::opt_showtype types are displayed, due to command \n",
1.440 + "line argument '--showtype=$::opt_showtype'\n\n";
1.441 + }
1.442 +
1.443 +}
1.444 +
1.445 +#----------------------------------------------------------------------
1.446 +#
1.447 +# Check for duplicate address ranges is Objects table, and
1.448 +# create list of sorted addresses for doing pointer-chasing
1.449 +
1.450 +sub validate_address_ranges() {
1.451 + # Build sorted list of address for validating interior pointers
1.452 + @::SortedAddresses = sort {$a <=> $b} keys %::Objects;
1.453 +
1.454 + # Validate non-overlap of memory
1.455 + my $prev_addr_end = -1;
1.456 + my $prev_addr = -1;
1.457 + my $index = 0;
1.458 + my $overlap_tally = 0; # overlapping object memory
1.459 + my $unused_tally = 0; # unused memory between blocks
1.460 + while ($index <= $#::SortedAddresses) {
1.461 + my $address = $::SortedAddresses[$index];
1.462 + if ($prev_addr_end > $address) {
1.463 + print "Object overlap from $::Objects{$prev_addr}->{'type'}:$prev_addr-$prev_addr_end into";
1.464 + my $test_index = $index;
1.465 + my $prev_addr_overlap_tally = 0;
1.466 +
1.467 + while ($test_index <= $#::SortedAddresses) {
1.468 + my $test_address = $::SortedAddresses[$test_index];
1.469 + last if ($prev_addr_end < $test_address);
1.470 + print " $::Objects{$test_address}->{'type'}:$test_address";
1.471 +
1.472 + $::Objects{$prev_addr}->{'overlap_count'}++;
1.473 + $::Objects{$test_address}->{'overlap_count'}++;
1.474 + my $overlap = $prev_addr_end - $test_address;
1.475 + if ($overlap > $::Objects{$test_address}->{'size'}) {
1.476 + $overlap = $::Objects{$test_address}->{'size'};
1.477 + }
1.478 + print "($overlap bytes)";
1.479 + $prev_addr_overlap_tally += $overlap;
1.480 +
1.481 + $test_index++;
1.482 + }
1.483 + print " [total $prev_addr_overlap_tally bytes]";
1.484 + $overlap_tally += $prev_addr_overlap_tally;
1.485 + print "\n";
1.486 + }
1.487 +
1.488 + $prev_addr = $address;
1.489 + $prev_addr_end = $prev_addr + $::Objects{$prev_addr}->{'size'} - 1;
1.490 + $index++;
1.491 + } #end while
1.492 + if ($overlap_tally) {
1.493 + print "Total overlap of $overlap_tally bytes\n";
1.494 + }
1.495 +}
1.496 +
1.497 +#----------------------------------------------------------------------
1.498 +#
1.499 +# Evaluate sizes of interobject spacing (fragmentation loss?)
1.500 +# Gather the sizes into histograms for analysis
1.501 +# This function assumes a sorted list of addresses is present globally
1.502 +
1.503 +sub generate_and_print_unused_memory_histogram() {
1.504 + print "\nInterobject spacing (fragmentation waste) Statistics\n";
1.505 + if ($::opt_fragment <= 1) {
1.506 + print "Statistics are not being gathered. Use '--fragment=10' to get stats\n";
1.507 + return;
1.508 + }
1.509 + print "Ratio of histogram buckets will be a factor of $::opt_fragment\n";
1.510 +
1.511 + my $prev_addr_end = -1;
1.512 + my $prev_addr = -1;
1.513 + my $index = 0;
1.514 +
1.515 + my @fragment_count;
1.516 + my @fragment_tally;
1.517 + my $power;
1.518 + my $bucket_size;
1.519 +
1.520 + my $max_power = 0;
1.521 +
1.522 + my $tally_sizes = 0;
1.523 +
1.524 + while ($index <= $#::SortedAddresses) {
1.525 + my $address = $::SortedAddresses[$index];
1.526 +
1.527 + my $unused = $address - $prev_addr_end;
1.528 +
1.529 + # handle overlaps gracefully
1.530 + if ($unused < 0) {
1.531 + $unused = 0;
1.532 + }
1.533 +
1.534 + $power = 0;
1.535 + $bucket_size = 1;
1.536 + while ($bucket_size < $unused) {
1.537 + $bucket_size *= $::opt_fragment;
1.538 + $power++;
1.539 + }
1.540 + $fragment_count[$power]++;
1.541 + $fragment_tally[$power] += $unused;
1.542 + if ($power > $max_power) {
1.543 + $max_power = $power;
1.544 + }
1.545 + my $size = $::Objects{$address}->{'size'};
1.546 + $tally_sizes += $size;
1.547 + $prev_addr_end = $address + $size - 1;
1.548 + $index++;
1.549 + }
1.550 +
1.551 +
1.552 + $power = 0;
1.553 + $bucket_size = 1;
1.554 + print "Basic gap histogram is (max_size:count):\n";
1.555 + while ($power <= $max_power) {
1.556 + if (! defined $fragment_count[$power]) {
1.557 + $fragment_count[$power] = $fragment_tally[$power] = 0;
1.558 + }
1.559 + printf " %.1f:", $bucket_size;
1.560 + print $fragment_count[$power];
1.561 + $power++;
1.562 + $bucket_size *= $::opt_fragment;
1.563 + }
1.564 + print "\n";
1.565 +
1.566 + print "Summary gap analysis:\n";
1.567 +
1.568 + $power = 0;
1.569 + $bucket_size = 1;
1.570 + my $tally = 0;
1.571 + my $count = 0;
1.572 + while ($power <= $max_power) {
1.573 + $count += $fragment_count[$power];
1.574 + $tally += $fragment_tally[$power];
1.575 + print "$count gaps, totaling $tally bytes, were under ";
1.576 + printf "%.1f bytes each", $bucket_size;
1.577 + if ($count) {
1.578 + printf ", for an average of %.1f bytes per gap", $tally/$count, ;
1.579 + }
1.580 + print "\n";
1.581 + $power++;
1.582 + $bucket_size *= $::opt_fragment;
1.583 + }
1.584 +
1.585 + print "Total allocation was $tally_sizes bytes, or ";
1.586 + printf "%.0f bytes per allocation block\n\n", $tally_sizes/($count+1);
1.587 +
1.588 +}
1.589 +
1.590 +#----------------------------------------------------------------------
1.591 +#
1.592 +# Now thread the parents and children together by looking through the
1.593 +# slots for each object.
1.594 +#
1.595 +sub create_parent_links(){
1.596 + my $min_addr = $::SortedAddresses[0];
1.597 + my $max_addr = $::SortedAddresses[ $#::SortedAddresses]; #allow one beyond each object
1.598 + $max_addr += $::Objects{$max_addr}->{'size'};
1.599 +
1.600 + print "Viable addresses range from $min_addr to $max_addr for a total of ",
1.601 + $max_addr-$min_addr, " bytes\n\n";
1.602 +
1.603 + # Gather stats as we try to convert slots to children
1.604 + my $slot_count = 0; # total slots examined
1.605 + my $fixed_addr_count = 0; # slots into interiors that were adjusted
1.606 + my $parent_child_count = 0; # Number of parent-child links
1.607 + my $child_count = 0; # valid slots, discounting sibling twins
1.608 + my $child_dup_count = 0; # number of duplicate child pointers
1.609 + my $self_pointer_count = 0; # count of discarded self-pointers
1.610 +
1.611 + foreach my $parent (keys %::Objects) {
1.612 + # We'll collect a list of this parent object's children
1.613 + # by iterating through its slots.
1.614 + my @children;
1.615 + my %children_hash;
1.616 + my $self_pointer = 0;
1.617 +
1.618 + my @slots = @{$::Objects{$parent}->{'slots'}};
1.619 + $slot_count += $#slots + 1;
1.620 + SLOT: foreach my $child (@slots) {
1.621 +
1.622 + # We only care about pointers that refer to other objects
1.623 + if (! defined $::Objects{$child}) {
1.624 + # check to see if we are an interior pointer
1.625 +
1.626 + # Punt if we are completely out of range
1.627 + next SLOT unless ($max_addr >= $child &&
1.628 + $child >= $min_addr);
1.629 +
1.630 + # Do binary search to find object below this address
1.631 + my ($min_index, $beyond_index) = (0, $#::SortedAddresses + 1);
1.632 + my $test_index;
1.633 + while ($min_index !=
1.634 + ($test_index = int (($beyond_index+$min_index)/2))) {
1.635 + if ($child >= $::SortedAddresses[$test_index]) {
1.636 + $min_index = $test_index;
1.637 + } else {
1.638 + $beyond_index = $test_index;
1.639 + }
1.640 + }
1.641 + # See if pointer is within extent of this object
1.642 + my $address = $::SortedAddresses[$test_index];
1.643 + next SLOT unless ($child <
1.644 + $address + $::Objects{$address}->{'size'});
1.645 +
1.646 + # Make adjustment so we point to the actual child precisely
1.647 + $child = $address;
1.648 + $fixed_addr_count++;
1.649 + }
1.650 +
1.651 + if ($child == $parent) {
1.652 + $self_pointer_count++;
1.653 + next SLOT; # Discard self-pointers
1.654 + }
1.655 +
1.656 + # Avoid creating duplicate child-parent links
1.657 + if (! defined $children_hash{$child}) {
1.658 + $parent_child_count++;
1.659 + # Add the parent to the child's list of parents
1.660 + my $parents = $::Objects{$child}->{'parents'};
1.661 + if (! $parents) {
1.662 + $parents = $::Objects{$child}->{'parents'} = [];
1.663 + }
1.664 +
1.665 + $parents->[scalar(@$parents)] = $parent;
1.666 +
1.667 + # Add the child to the parent's list of children
1.668 + $children_hash{$child} = 1;
1.669 + } else {
1.670 + $child_dup_count++;
1.671 + }
1.672 + }
1.673 + @children = keys %children_hash;
1.674 + # Track tally of unique children linked
1.675 + $child_count += $#children + 1;
1.676 +
1.677 + $::Objects{$parent}->{'children'} = \@children;
1.678 +
1.679 + if (! @children) {
1.680 + $::Leafs[$#::Leafs + 1] = $parent;
1.681 + }
1.682 + }
1.683 + print "Scanning $#::SortedAddresses objects, we found $parent_child_count parents-to-child connections by chasing $slot_count pointers.\n",
1.684 + "This required $fixed_addr_count interior pointer fixups, skipping $child_dup_count duplicate pointers, ",
1.685 + "and $self_pointer_count self pointers\nAlso discarded ",
1.686 + $slot_count - $parent_child_count -$self_pointer_count - $child_dup_count,
1.687 + " out-of-range pointers\n\n";
1.688 +}
1.689 +
1.690 +
1.691 +#----------------------------------------------------------------------
1.692 +# For every leaf, if a leaf has only one parent, then sweep the memory
1.693 +# cost into the parent from the leaf
1.694 +sub sweep_leaf_memory () {
1.695 + my $sweep_count = 0;
1.696 + my $leaf_counter = 0;
1.697 + LEAF: while ($leaf_counter <= $#::Leafs) {
1.698 + my $leaf_addr = $::Leafs[$leaf_counter++];
1.699 + my $leaf_obj = $::Objects{$leaf_addr};
1.700 + my $parents = $leaf_obj->{'parents'};
1.701 +
1.702 + next LEAF if (! defined($parents) || 1 != scalar(@$parents));
1.703 +
1.704 + # We have only one parent, so we'll try to sweep upwards
1.705 + my $parent_addr = @$parents[0];
1.706 + my $parent_obj = $::Objects{$parent_addr};
1.707 +
1.708 + # watch out for self-pointers
1.709 + next LEAF if ($parent_addr == $leaf_addr);
1.710 +
1.711 + if ($::opt_detail) {
1.712 + foreach my $obj ($parent_obj, $leaf_obj) {
1.713 + if (!defined $obj->{'original_size'}) {
1.714 + $obj->{'original_size'} = $obj->{'size'};
1.715 + }
1.716 + }
1.717 + if (defined $leaf_obj->{'sweep_details'}) {
1.718 + if (defined $parent_obj->{'sweep_details'}) { # merge details
1.719 + foreach my $swept_obj (keys (%{$leaf_obj->{'sweep_details'}})) {
1.720 + %{$parent_obj->{'sweep_details'}}->{$swept_obj} =
1.721 + %{$leaf_obj->{'sweep_details'}}->{$swept_obj};
1.722 + }
1.723 + } else { # No parent info
1.724 + $parent_obj->{'sweep_details'} = \%{$leaf_obj->{'sweep_details'}};
1.725 + }
1.726 + delete $leaf_obj->{'sweep_details'};
1.727 + } else { # no leaf detail
1.728 + if (!defined $parent_obj->{'sweep_details'}) {
1.729 + $parent_obj->{'sweep_details'} = {};
1.730 + }
1.731 + }
1.732 + %{$parent_obj->{'sweep_details'}}->{$leaf_addr} = $leaf_obj->{'original_size'};
1.733 + }
1.734 +
1.735 + $parent_obj->{'size'} += $leaf_obj->{'size'};
1.736 + $leaf_obj->{'size'} = 0;
1.737 +
1.738 + if (defined ($leaf_obj->{'swept_in'})) {
1.739 + $parent_obj->{'swept_in'} += $leaf_obj->{'swept_in'};
1.740 + $leaf_obj->{'swept_in'} = 0; # sweep has been handed off to parent
1.741 + }
1.742 + $parent_obj->{'swept_in'} ++; # tally swept in leaf_obj
1.743 +
1.744 + $sweep_count++;
1.745 +
1.746 + # See if we created another leaf
1.747 + my $consumed_children = $parent_obj->{'consumed'}++;
1.748 + my @children = $parent_obj->{'children'};
1.749 + if ($consumed_children == $#children) {
1.750 + $::Leafs[$#::Leafs + 1] = @$parents[0];
1.751 + }
1.752 + }
1.753 + print "Processed ", $leaf_counter, " leaves sweeping memory to parents in ", $sweep_count, " objects\n";
1.754 +}
1.755 +
1.756 +
1.757 +#----------------------------------------------------------------------
1.758 +#
1.759 +# Subdivide the types of objects that are in our "expand" list
1.760 +# List types that should be sub-divided based on parents, and possibly
1.761 +# children
1.762 +# The argument supplied is a hash table with keys selecting types that
1.763 +# need to be "refined" by including the types of the parent objects,
1.764 +# and (when we are desparate) the types of the children objects.
1.765 +
1.766 +sub expand_type_names($) {
1.767 + my %TypeExpand = %{$_[0]};
1.768 +
1.769 + my @retype; # array of addrs that get extended type names
1.770 + foreach my $child (keys %::Objects) {
1.771 + my $child_obj = $::Objects{$child};
1.772 + next unless (defined ($TypeExpand{$child_obj->{'type'}}));
1.773 +
1.774 + foreach my $relation ('parents','children') {
1.775 + my $relatives = $child_obj->{$relation};
1.776 + next unless defined @$relatives;
1.777 +
1.778 + # Sort out the names of the types of the relatives
1.779 + my %names;
1.780 + foreach my $relative (@$relatives) {
1.781 + %names->{$::Objects{$relative}->{'type'}} = 1;
1.782 + }
1.783 + my $related_type_names = join(',' , sort(keys(%names)));
1.784 +
1.785 +
1.786 + $child_obj->{'name' . $relation} = $related_type_names;
1.787 +
1.788 + # Don't bother with children if we have significant parent types
1.789 + last if (!defined ($TypeExpand{$related_type_names}));
1.790 + }
1.791 + $retype[$#retype + 1] = $child;
1.792 + }
1.793 +
1.794 + # Revisit all addresses we've marked
1.795 + foreach my $child (@retype) {
1.796 + my $child_obj = $::Objects{$child};
1.797 + $child_obj->{'type'} = $TypeExpand{$child_obj->{'type'}};
1.798 + my $extended_type = $child_obj->{'namechildren'};
1.799 + if (defined $extended_type) {
1.800 + $child_obj->{'type'}.= "->(" . $extended_type . ")";
1.801 + delete ($child_obj->{'namechildren'});
1.802 + }
1.803 + $extended_type = $child_obj->{'nameparents'};
1.804 + if (defined $extended_type) {
1.805 + $child_obj->{'type'} = "(" . $extended_type . ")->" . $::Objects{$child}->{'type'};
1.806 + delete ($child_obj->{'nameparents'});
1.807 + }
1.808 + }
1.809 +}
1.810 +
1.811 +#----------------------------------------------------------------------
1.812 +#
1.813 +# Print out a type histogram
1.814 +
1.815 +sub print_type_histogram() {
1.816 + load_type_table();
1.817 + print_type_table();
1.818 + print "\n\n";
1.819 +}
1.820 +
1.821 +
1.822 +#----------------------------------------------------------------------
1.823 +# Provide a nice summary of the types during the process
1.824 +validate_address_ranges();
1.825 +create_parent_links();
1.826 +
1.827 +print "\nBasic memory use histogram is:\n";
1.828 +print_type_histogram();
1.829 +
1.830 +generate_and_print_unused_memory_histogram();
1.831 +
1.832 +sweep_leaf_memory ();
1.833 +print "After doing basic leaf-sweep processing of instances:\n";
1.834 +print_type_histogram();
1.835 +
1.836 +{
1.837 + foreach my $typename (@::opt_typedivide) {
1.838 + my %expansion_table;
1.839 + $expansion_table{$typename} = $typename;
1.840 + expand_type_names(\%expansion_table);
1.841 + print "After subdividing <$typename> based on inbound (and somtimes outbound) pointers:\n";
1.842 + print_type_histogram();
1.843 + }
1.844 +}
1.845 +
1.846 +exit(); # Don't bother with SCCs yet.
1.847 +
1.848 +
1.849 +#----------------------------------------------------------------------
1.850 +#
1.851 +# Determine objects that entrain equivalent sets, using the strongly
1.852 +# connected component algorithm from Cormen, Leiserson, and Rivest,
1.853 +# ``An Introduction to Algorithms'', MIT Press 1990, pp. 488-493.
1.854 +#
1.855 +sub compute_post_order($$$) {
1.856 +# This routine produces a post-order of the call graph (what CLR call
1.857 +# ``ordering the nodes by f[u]'')
1.858 + my ($parent, $visited, $finish) = @_;
1.859 +
1.860 + # Bail if we've already seen this node
1.861 + return if $visited->{$parent};
1.862 +
1.863 + # We have now!
1.864 + $visited->{$parent} = 1;
1.865 +
1.866 + # Walk the children
1.867 + my $children = $::Objects{$parent}->{'children'};
1.868 +
1.869 + foreach my $child (@$children) {
1.870 + compute_post_order($child, $visited, $finish);
1.871 + }
1.872 +
1.873 + # Now that we've walked all the kids, we can append the parent to
1.874 + # the post-order
1.875 + @$finish[scalar(@$finish)] = $parent;
1.876 +}
1.877 +
1.878 +sub compute_equivalencies($$$) {
1.879 +# This routine recursively computes equivalencies by walking the
1.880 +# transpose of the callgraph.
1.881 + my ($child, $table, $equivalencies) = @_;
1.882 +
1.883 + # Bail if we've already seen this node
1.884 + return if $table->{$child};
1.885 +
1.886 + # Otherwise, append ourself to the list of equivalencies...
1.887 + @$equivalencies[scalar(@$equivalencies)] = $child;
1.888 +
1.889 + # ...and note our other equivalents in the table
1.890 + $table->{$child} = $equivalencies;
1.891 +
1.892 + my $parents = $::Objects{$child}->{'parents'};
1.893 +
1.894 + foreach my $parent (@$parents) {
1.895 + compute_equivalencies($parent, $table, $equivalencies);
1.896 + }
1.897 +}
1.898 +
1.899 +sub compute_equivalents() {
1.900 +# Here's the strongly connected components algorithm. (Step 2 has been
1.901 +# done implictly by our object graph construction.)
1.902 + my %visited;
1.903 + my @finish;
1.904 +
1.905 + # Step 1. Compute a post-ordering of the object graph
1.906 + foreach my $parent (keys %::Objects) {
1.907 + compute_post_order($parent, \%visited, \@finish);
1.908 + }
1.909 +
1.910 + # Step 3. Traverse the transpose of the object graph in reverse
1.911 + # post-order, collecting vertices into %equivalents
1.912 + my %equivalents;
1.913 + foreach my $child (reverse @finish) {
1.914 + compute_equivalencies($child, \%equivalents, []);
1.915 + }
1.916 +
1.917 + # Now, we'll trim the %equivalents table, arbitrarily removing
1.918 + # ``redundant'' entries.
1.919 + EQUIVALENT: foreach my $node (keys %equivalents) {
1.920 + my $equivalencies = $equivalents{$node};
1.921 + next EQUIVALENT unless $equivalencies;
1.922 +
1.923 + foreach my $equivalent (@$equivalencies) {
1.924 + delete $equivalents{$equivalent} unless $equivalent == $node;
1.925 + }
1.926 + }
1.927 +
1.928 + # Note the equivalent objects in a way that will yield the most
1.929 + # interesting order as we do depth-first traversal later to
1.930 + # output them.
1.931 + ROOT: foreach my $equivalent (reverse @finish) {
1.932 + next ROOT unless $equivalents{$equivalent};
1.933 + $::Equivalents[$#::Equivalents + 1] = $equivalent;
1.934 +
1.935 + # XXX Lame! Should figure out function refs.
1.936 + $::Objects{$equivalent}->{'entrained-size'} = 0;
1.937 + }
1.938 +}
1.939 +
1.940 +# Do it!
1.941 +compute_equivalents();
1.942 +
1.943 +
1.944 +#----------------------------------------------------------------------
1.945 +#
1.946 +# Compute the size of each node's transitive closure.
1.947 +#
1.948 +sub compute_entrained($$) {
1.949 + my ($parent, $visited) = @_;
1.950 +
1.951 + $visited->{$parent} = 1;
1.952 +
1.953 + $::Objects{$parent}->{'entrained-size'} = $::Objects{$parent}->{'size'};
1.954 +
1.955 + my $children = $::Objects{$parent}->{'children'};
1.956 + CHILD: foreach my $child (@$children) {
1.957 + next CHILD if $visited->{$child};
1.958 +
1.959 + compute_entrained($child, $visited);
1.960 + $::Objects{$parent}->{'entrained-size'} += $::Objects{$child}->{'entrained-size'};
1.961 + }
1.962 +}
1.963 +
1.964 +if (! $::opt_noentrained) {
1.965 + my %visited;
1.966 +
1.967 + PARENT: foreach my $parent (@::Equivalents) {
1.968 + next PARENT if $visited{$parent};
1.969 + compute_entrained($parent, \%visited);
1.970 + }
1.971 +}
1.972 +
1.973 +
1.974 +#----------------------------------------------------------------------
1.975 +#
1.976 +# Converts a shared library and an address into a file and line number
1.977 +# using a bunch of addr2line processes.
1.978 +#
1.979 +sub addr2line($$) {
1.980 + my ($dso, $addr) = @_;
1.981 +
1.982 + # $::Addr2Lines is a global table that maps a DSO's name to a pair
1.983 + # of filehandles that are talking to an addr2line process.
1.984 + my $fhs = $::Addr2Lines{$dso};
1.985 + if (! $fhs) {
1.986 + if (!(-r $dso)) {
1.987 + # bogus filename (that happens sometimes), so bail
1.988 + return { 'dso' => $dso, 'addr' => $addr };
1.989 + }
1.990 + my ($in, $out) = (new FileHandle, new FileHandle);
1.991 + open2($in, $out, "addr2line --exe=$dso") || die "unable to open addr2line --exe=$dso";
1.992 + $::Addr2Lines{$dso} = $fhs = { 'in' => $in, 'out' => $out };
1.993 + }
1.994 +
1.995 + # addr2line takes a hex address as input...
1.996 + $fhs->{'out'}->print($addr . "\n");
1.997 +
1.998 + # ...and'll return file:lineno as output
1.999 + if ($fhs->{'in'}->getline() =~ /([^:]+):(.+)/) {
1.1000 + return { 'file' => $1, 'line' => $2 };
1.1001 + }
1.1002 + else {
1.1003 + return { 'dso' => $dso, 'addr' => $addr };
1.1004 + }
1.1005 +}
1.1006 +
1.1007 +
1.1008 +#----------------------------------------------------------------------
1.1009 +#
1.1010 +# Dump the objects, using a depth-first traversal.
1.1011 +#
1.1012 +sub dump_objects($$$) {
1.1013 + my ($parent, $visited, $depth) = @_;
1.1014 +
1.1015 + # Have we already seen this?
1.1016 + my $already_visited = $visited->{$parent};
1.1017 + return if ($depth == 0 && $already_visited);
1.1018 +
1.1019 + if (! $already_visited) {
1.1020 + $visited->{$parent} = 1;
1.1021 + $::Total += $::Objects{$parent}->{'size'};
1.1022 + }
1.1023 +
1.1024 + my $parententry = $::Objects{$parent};
1.1025 +
1.1026 + # Make an ``object'' div, which'll contain an ``object'' span, two
1.1027 + # ``toggle'' spans, an invisible ``stack'' div, and the invisible
1.1028 + # ``children'' div.
1.1029 + print "<div class='object'>";
1.1030 +
1.1031 + if ($already_visited) {
1.1032 + print "<a href='#$parent'>";
1.1033 + }
1.1034 + else {
1.1035 + print "<span id='$parent' class='object";
1.1036 + print " root" if $depth == 0;
1.1037 + print "'>";
1.1038 + }
1.1039 +
1.1040 + printf "0x%x<%s>[%d]", $parent, $parententry->{'type'}, $parententry->{'size'};
1.1041 +
1.1042 + if ($already_visited) {
1.1043 + print "</a>";
1.1044 + goto DONE;
1.1045 + }
1.1046 +
1.1047 + if ($depth == 0) {
1.1048 + print "($parententry->{'entrained-size'})"
1.1049 + if $parententry->{'entrained-size'};
1.1050 +
1.1051 + print " <span class='toggle' onclick='toggleDisplay(this.parentNode.nextSibling.nextSibling);'>Children</span>"
1.1052 + if @{$parententry->{'children'}} > 0;
1.1053 + }
1.1054 +
1.1055 + if (($depth == 0 || !$::opt_nochildstacks) && !$::opt_nostacks) {
1.1056 + print " <span class='toggle' onclick='toggleDisplay(this.parentNode.nextSibling);'>Stack</span>";
1.1057 + }
1.1058 +
1.1059 + print "</span>";
1.1060 +
1.1061 + # Print stack traces
1.1062 + print "<div class='stack'>\n";
1.1063 +
1.1064 + if (($depth == 0 || !$::opt_nochildstacks) && !$::opt_nostacks) {
1.1065 + my $depth = $::opt_depth;
1.1066 +
1.1067 + FRAME: foreach my $frame (@{$parententry->{'stack'}}) {
1.1068 + # Only go as deep as they've asked us to.
1.1069 + last FRAME unless --$depth >= 0;
1.1070 +
1.1071 + # Stack frames look like ``mangled_name[dso address]''
1.1072 + $frame =~ /([^\]]+)\[(.*) \+0x([0-9A-Fa-f]+)\]/;
1.1073 +
1.1074 + # Convert address to file and line number
1.1075 + my $mangled = $1;
1.1076 + my $result = addr2line($2, $3);
1.1077 +
1.1078 + if ($result->{'file'}) {
1.1079 + # It's mozilla source! Clean up refs to dist/include
1.1080 + if (($result->{'file'} =~ s/.*\.\.\/\.\.\/dist\/include\//http:\/\/bonsai.mozilla.org\/cvsguess.cgi\?file=/) ||
1.1081 + ($result->{'file'} =~ s/.*\/mozilla/http:\/\/bonsai.mozilla.org\/cvsblame.cgi\?file=mozilla/)) {
1.1082 + my $prevline = $result->{'line'} - 10;
1.1083 + print "<a target=\"lxr_source\" href=\"$result->{'file'}\&mark=$result->{'line'}#$prevline\">$mangled</a><br>\n";
1.1084 + }
1.1085 + else {
1.1086 + print "$mangled ($result->{'file'}, line $result->{'line'})<br>\n";
1.1087 + }
1.1088 + }
1.1089 + else {
1.1090 + print "$result->{'dso'} ($result->{'addr'})<br>\n";
1.1091 + }
1.1092 + }
1.1093 +
1.1094 + }
1.1095 +
1.1096 + print "</div>";
1.1097 +
1.1098 + # Recurse to children
1.1099 + if (@{$parententry->{'children'}} >= 0) {
1.1100 + print "<div class='children'>\n" if $depth == 0;
1.1101 +
1.1102 + foreach my $child (@{$parententry->{'children'}}) {
1.1103 + dump_objects($child, $visited, $depth + 1);
1.1104 + }
1.1105 +
1.1106 + print "</div>" if $depth == 0;
1.1107 + }
1.1108 +
1.1109 + DONE:
1.1110 + print "</div>\n";
1.1111 +}
1.1112 +
1.1113 +
1.1114 +#----------------------------------------------------------------------
1.1115 +#
1.1116 +# Do the output.
1.1117 +#
1.1118 +
1.1119 +# Force flush on STDOUT. We get funky output unless we do this.
1.1120 +$| = 1;
1.1121 +
1.1122 +# Header
1.1123 +print "<html>
1.1124 +<head>
1.1125 +<title>Object Graph</title>
1.1126 +<style type='text/css'>
1.1127 + body { font: medium monospace; background-color: white; }
1.1128 +
1.1129 + /* give nested div's some margins to make it look like a tree */
1.1130 + div.children > div.object { margin-left: 1em; }
1.1131 + div.object > div.object { margin-left: 1em; }
1.1132 +
1.1133 + /* Indent stacks, too */
1.1134 + div.object > div.stack { margin-left: 3em; }
1.1135 +
1.1136 + /* apply font decorations to special ``object'' spans */
1.1137 + span.object { font-weight: bold; color: darkgrey; }
1.1138 + span.object.root { color: black; }
1.1139 +
1.1140 + /* hide ``stack'' divs by default; JS will show them */
1.1141 + div.stack { display: none; }
1.1142 +
1.1143 + /* hide ``children'' divs by default; JS will show them */
1.1144 + div.children { display: none; }
1.1145 +
1.1146 + /* make ``toggle'' spans look like links */
1.1147 + span.toggle { color: blue; text-decoration: underline; cursor: pointer; }
1.1148 + span.toggle:active { color: red; }
1.1149 +</style>
1.1150 +<script language='JavaScript'>
1.1151 +function toggleDisplay(element)
1.1152 +{
1.1153 + element.style.display = (element.style.display == 'block') ? 'none' : 'block';
1.1154 +}
1.1155 +</script>
1.1156 +</head>
1.1157 +<body>
1.1158 +";
1.1159 +
1.1160 +{
1.1161 +# Body. Display ``roots'', sorted by the amount of memory they
1.1162 +# entrain. Because of the way we've sorted @::Equivalents, we should
1.1163 +# get a nice ordering that sorts things with a lot of kids early
1.1164 +# on. This should yield a fairly "deep" depth-first traversal, with
1.1165 +# most of the objects appearing as children.
1.1166 +#
1.1167 +# XXX I sure hope that Perl implements a stable sort!
1.1168 + my %visited;
1.1169 +
1.1170 + foreach my $parent (sort { $::Objects{$b}->{'entrained-size'}
1.1171 + <=> $::Objects{$a}->{'entrained-size'} }
1.1172 + @::Equivalents) {
1.1173 + dump_objects($parent, \%visited, 0);
1.1174 + print "\n";
1.1175 + }
1.1176 +}
1.1177 +
1.1178 +# Footer
1.1179 +print "<br> $::Total total bytes\n" if $::Total;
1.1180 +print "</body>
1.1181 +</html>
1.1182 +";
1.1183 +
