CLOSED TREE: TraceMonkey merge head. (a=blockers)
[mozilla-central.git] / tools / trace-malloc / leak-soup.pl
blob673af81276548b25c4cb149469a8beb20c2b9c5f
1 #!/usr/bin/perl -w
3 # ***** BEGIN LICENSE BLOCK *****
4 # Version: MPL 1.1/GPL 2.0/LGPL 2.1
6 # The contents of this file are subject to the Mozilla Public License Version
7 # 1.1 (the "License"); you may not use this file except in compliance with
8 # the License. You may obtain a copy of the License at
9 # http://www.mozilla.org/MPL/
11 # Software distributed under the License is distributed on an "AS IS" basis,
12 # WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
13 # for the specific language governing rights and limitations under the
14 # License.
16 # The Original Code is leak-soup.pl, released
17 # Oct 1, 2000.
19 # The Initial Developer of the Original Code is
20 # Netscape Communications Corporation.
21 # Portions created by the Initial Developer are Copyright (C) 2000
22 # the Initial Developer. All Rights Reserved.
24 # Contributor(s):
25 # Chris Waterson <waterson@netscape.com>
26 # Jim Roskind <jar@netscape.com>
28 # Alternatively, the contents of this file may be used under the terms of
29 # either the GNU General Public License Version 2 or later (the "GPL"), or
30 # the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
31 # in which case the provisions of the GPL or the LGPL are applicable instead
32 # of those above. If you wish to allow use of your version of this file only
33 # under the terms of either the GPL or the LGPL, and not to allow others to
34 # use your version of this file under the terms of the MPL, indicate your
35 # decision by deleting the provisions above and replace them with the notice
36 # and other provisions required by the GPL or the LGPL. If you do not delete
37 # the provisions above, a recipient may use your version of this file under
38 # the terms of any one of the MPL, the GPL or the LGPL.
40 # ***** END LICENSE BLOCK *****
42 # A perl version of Patrick Beard's ``Leak Soup'', which processes the
43 # stack crawls from the Boehm GC into a graph.
45 use 5.004;
46 use strict;
47 use Getopt::Long;
48 use FileHandle;
49 use IPC::Open2;
51 # Collect program options
52 $::opt_help = 0;
53 $::opt_detail = 0;
54 $::opt_fragment = 1.0; # Default to no fragment analysis
55 $::opt_nostacks = 0;
56 $::opt_nochildstacks = 0;
57 $::opt_depth = 9999;
58 $::opt_noentrained = 0;
59 $::opt_noslop = 0;
60 $::opt_showtype = -1; # default to listing all types
61 $::opt_stackrefine = "C";
62 @::opt_stackretype = ();
63 @::opt_stackskipclass = ();
64 @::opt_stackskipfunc = ();
65 @::opt_typedivide = ();
67 GetOptions("help", "detail", "format=s", "fragment=f", "nostacks",
68 "nochildstacks", "depth=i", "noentrained", "noslop", "showtype=i",
69 "stackrefine=s", "stackretype=s@", "stackskipclass=s@", "stackskipfunc=s@",
70 "typedivide=s@"
73 if ($::opt_help) {
74 die "usage: leak-soup.pl [options] <leakfile>
75 --help Display this message
76 --detail Provide details of memory sweeping from child to parents
77 --fragment=ratio Histogram bucket ratio for fragmentation analysis
78 # --nostacks Do not compute stack traces
79 # --nochildstacks Do not compute stack traces for entrained objects
80 # --depth=<max> Only compute stack traces to depth of <max>
81 # --noentrained Do not compute amount of memory entrained by root objects
82 --noslop Don't ignore low bits when searching for pointers
83 --showtype=<i> Show memory usage histogram for most-significant <i> types
84 --stackrefine={F|C} During stack based refinement, use 'F'ull name name or just 'C'lass
85 --stackretype=type Use allocation stack to refine vague types like void*
86 --stackskipclass=class When refining types, ignore stack frames from 'class'
87 --stackskipfunc=func When refining types, ignore stack frames for 'func'
88 --typedivide=type Subdivide 'type' based on objects pointing to each instance
92 # This is the table that keeps a graph of objects. It's indexed by the
93 # object's address (as an integer), and refers to a simple hash that
94 # has information about the object's type, size, slots, and allocation
95 # stack.
96 %::Objects = %{0};
98 # This will be a list of keys to (addresses in) Objects, that is sorted
99 # It gets used to evaluate overlaps, calculate fragmentation, and chase
100 # parent->child (interior) pointers.
101 @::SortedAddresses = [];
103 # This is the table that keeps track of memory usage on a per-type basis.
104 # It is indexed by the type name (string), and keeps a tally of the
105 # total number of such objects, and the memory usage of such objects.
106 %::Types = %{0};
107 $::TotalSize = 0; # sum of sizes of all objects included $::Types{}
109 # This is an array of leaf node addresses. A leaf node has no children
110 # with memory allocations. We traverse them sweeping memory
111 # tallies into parents. Note that after all children have
112 # been swept into a parent, that parent may also become a leaf node.
113 @::Leafs = @{0};
118 #----------------------------------------------------------------------
120 # Decode arguments to override default values for doing call-stack-based
121 # refinement of typename based on contents of the stack at allocation time.
124 # List the types that we need to refine (if any) based on allocation stack
125 $::VagueType = {
126 'void*' => 1,
129 # With regard to the stack, ignore stack frames in the following
130 # overly vague classes.
131 $::VagueClasses = {
132 # 'nsStr' => 1,
133 'nsVoidArray' => 1,
136 # With regard to stack, ignore stack frames with the following vague
137 # function names
138 $::VagueFunctions = {
139 'PL_ArenaAllocate' => 1,
140 'PL_HashTableFinalize(PLHashTable *)' => 1,
141 'PL_HashTableInit__FP11PLHashTableUiPFPCv_UiPFPCvPCv_iT3PC14PLHashAllocOpsPv' => 1,
142 'PL_HashTableRawAdd' => 1,
143 '__builtin_vec_new' => 1,
144 '_init' => 1,
145 'il_get_container(_IL_GroupContext *, ImgCachePolicy, char const *, _NI_IRGB *, IL_DitherMode, int, int, int)' => 1,
146 'nsCStringKey::Clone(void) const' => 1,
147 'nsCppSharedAllocator<unsigned short>::allocate(unsigned int, void const *)' => 1,
148 'nsHashtable::Put(nsHashKey *, void *)' => 1,
149 'nsHashtable::nsHashtable(unsigned int, int)' => 1,
150 'nsMemory::Alloc(unsigned int)' => 1,
151 'nsMemoryImpl::Alloc(unsigned int)' => 1,
154 sub init_stack_based_type_refinement() {
155 # Move across stackretype options, or use default values
156 if ($#::opt_stackretype < 0) {
157 print "Default --stackretype options will be used (since none were specified)\n";
158 print " use --stackretype='nothing' to disable re-typing activity\n";
159 } else {
160 foreach my $type (keys %{$::VagueType}) {
161 delete ($::VagueType->{$type});
163 if ($#::opt_stackretype == 0 && $::opt_stackretype[0] eq 'nothing') {
164 print "Types will not be refined based on call stack\n";
165 } else {
166 foreach my $type (@::opt_stackretype) {
167 $::VagueType->{$type} = 1;
173 if (keys %{$::VagueType}) {
174 print "The following type(s) will be refined based on call stacks:\n";
175 foreach my $type (sort keys %{$::VagueType}) {
176 print " $type\n";
178 print "Equivalent command line argument(s):\n";
179 foreach my $type (sort keys %{$::VagueType}) {
180 print " --stackretype='$type'";
182 print "\n\n";
184 if ($#::opt_stackskipclass < 0) {
185 print "Default --stackskipclass options will be used (since none were specified)\n";
186 print " use --stackskipclass='nothing' to disable skipping stack frames based on class names\n";
187 } else {
188 foreach my $type (keys %{$::VagueClasses}) {
189 delete ($::VagueClasses->{$type});
191 if ($#::opt_stackskipclass == 0 && $::opt_stackskipclass[0] eq 'nothing') {
192 print "Types will not be refined based on call stack\n";
193 } else {
194 foreach my $type (@::opt_stackskipclass) {
195 $::VagueClasses->{$type} = 1;
200 if (keys %{$::VagueClasses}) {
201 print "Stack frames from the following class(es) will not be used to refine types:\n";
202 foreach my $class (sort keys %{$::VagueClasses}) {
203 print " $class\n";
205 print "Equivalent command line argument(s):\n";
206 foreach my $class (sort keys %{$::VagueClasses}) {
207 print " --stackskipclass='$class'";
209 print "\n\n";
213 if ($#::opt_stackskipfunc < 0) {
214 print "Default --stackskipfunc options will be used (since none were specified)\n";
215 print " use --stackskipfunc='nothing' to disable skipping stack frames based on function names\n";
216 } else {
217 foreach my $type (keys %{$::VagueFunctions}) {
218 delete ($::VagueFunctions->{$type});
220 if ($#::opt_stackskipfunc == 0 && $::opt_stackskipfunc[0] eq 'nothing') {
221 print "Types will not be refined based on call stack\n";
222 } else {
223 foreach my $type (@::opt_stackskipfunc) {
224 $::VagueFunctions->{$type} = 1;
229 if (keys %{$::VagueFunctions}) {
230 print "Stack frames from the following function(s) will not be used to refine types:\n";
231 foreach my $func (sort keys %{$::VagueFunctions}) {
232 print " $func\n";
234 print "Equivalent command line argument(s):\n";
235 foreach my $func (sort keys %{$::VagueFunctions}) {
236 print " --stackskipfunc='$func'";
238 print "\n\n";
244 #----------------------------------------------------------------------
246 # Read in the output from the Boehm GC or Trace-malloc.
248 sub read_boehm() {
249 OBJECT: while (<>) {
250 # e.g., 0x0832FBD0 <void*> (80)
251 next OBJECT unless /^0x(\S+) <(.*)> \((\d+)\)/;
252 my ($addr, $type, $size) = (hex $1, $2, $3);
254 my $object = $::Objects{$addr};
255 if (! $object) {
256 # Found a new object entry. Record its type and size
257 $::Objects{$addr} =
258 $object =
259 { 'type' => $type, 'size' => $size };
260 } else {
261 print "Duplicate address $addr contains $object->{'type'} and $type\n";
262 $object->{'dup_addr_count'}++;
265 # Record the object's slots
266 my @slots;
268 SLOT: while (<>) {
269 # e.g., 0x00000000
270 last SLOT unless /^\t0x(\S+)/;
271 my $value = hex $1;
273 # Ignore low bits, unless they've specified --noslop
274 $value &= ~0x7 unless $::opt_noslop;
276 $slots[$#slots + 1] = $value;
279 $object->{'slots'} = \@slots;
281 if (@::opt_stackretype && (defined $::VagueType->{$type})) {
282 # Change the value of type of the object based on stack
283 # if we can find an interesting calling function
284 VAGUEFRAME: while (<>) {
285 # e.g., _dl_debug_message[/lib/ld-linux.so.2 +0x0000B858]
286 last VAGUEFRAMEFRAME unless /^(.*)\[(.*) \+0x(\S+)\]$/;
287 my ($func, $lib, $off) = ($1, $2, hex $3);
288 chomp;
290 my ($class,,$fname) = split(/:/, $func);
291 next VAGUEFRAME if (defined $::VagueFunctions->{$func} ||
292 defined $::VagueClasses->{$class});
294 # Refine typename and exit stack scan
295 $object->{'type'} = $type . ":" .
296 (('C' eq $::opt_stackrefine) ?
297 $class :
298 $func);
299 last VAGUEFRAME;
301 } else {
302 # Save all stack info if requested
303 if (! $::opt_nostacks) {
304 # Record the stack by which the object was allocated
305 my @stack;
307 FRAME: while (<>) {
308 # e.g., _dl_debug_message[/lib/ld-linux.so.2 +0x0000B858]
309 last FRAME unless /^(.*)\[(.*) \+0x(\S+)\]$/;
310 my ($func, $lib, $off) = ($1, $2, hex $3);
311 chomp;
313 $stack[$#stack + 1] = $_;
316 $object->{'stack'} = \@stack;
320 # Gotta check EOF explicitly...
321 last OBJECT if eof;
326 #----------------------------------------------------------------------
328 # Read input
330 init_stack_based_type_refinement();
331 read_boehm;
335 #----------------------------------------------------------------------
337 # Do basic initialization of the type hash table. Accumulate
338 # total counts, and basic memory usage (not including children)
339 sub load_type_table() {
340 # Reset global counter and hash table
341 $::TotalSize = 0;
342 %::Types = %{0};
344 OBJECT: foreach my $addr (keys %::Objects) {
345 my $obj = $::Objects{$addr};
346 my ($type, $size, $swept_in, $overlap_count, $dup_addr_count) =
347 ($obj->{'type'}, $obj->{'size'},
348 $obj->{'swept_in'},
349 $obj->{'overlap_count'},$obj->{'dup_addr_count'});
351 my $type_data = $::Types{$type};
352 if (! defined $type_data) {
353 $::Types{$type} =
354 $type_data = {'count' => 0, 'size' => 0,
355 'max' => $size, 'min' => $size,
356 'swept_in' => 0, 'swept' => 0,
357 'overlap_count' => 0,
358 'dup_addr_count' => 0};
361 if (!$size) {
362 $type_data->{'swept'}++;
363 next OBJECT;
365 $::TotalSize += $size;
367 $type_data->{'count'}++;
368 $type_data->{'size'} += $size;
369 if (defined $swept_in) {
370 $type_data->{'swept_in'} += $swept_in;
372 if ($::opt_detail) {
373 my $type_detail_sizes = $type_data->{'sweep_details_size'};
374 my $type_detail_counts;
375 if (!defined $type_detail_sizes) {
376 $type_detail_sizes = $type_data->{'sweep_details_size'} = {};
377 $type_detail_counts = $type_data->{'sweep_details_count'} = {};
378 } else {
379 $type_detail_counts = $type_data->{'sweep_details_count'};
382 my $sweep_details = $obj->{'sweep_details'};
383 for my $swept_addr (keys (%{$sweep_details})) {
384 my $swept_obj = $::Objects{$swept_addr};
385 my $swept_type = $swept_obj->{'type'};
386 $type_detail_sizes->{$swept_type} += $sweep_details->{$swept_addr};
387 $type_detail_counts->{$swept_type}++;
391 if (defined $overlap_count) {
392 $type_data->{'overlap_count'} += $overlap_count;
395 if (defined $dup_addr_count) {
396 $type_data->{'dup_addr_count'} += $dup_addr_count;
399 if ($type_data->{'max'} < $size) {
400 $type_data->{'max'} = $size;
402 # Watch out for case where min is produced by a swept object
403 if (!$type_data->{'min'} || $type_data->{'min'} > $size) {
404 $type_data->{'min'} = $size;
410 #----------------------------------------------------------------------
411 sub print_type_table(){
412 if (!$::opt_showtype) {
413 return;
415 my $line_count = 0;
416 my $bytes_printed_tally = 0;
418 # Display type summary information
419 my @sorted_types = keys (%::Types);
420 print "There are ", 1 + $#sorted_types, " types containing ", $::TotalSize, " bytes\n";
421 @sorted_types = sort {$::Types{$b}->{'size'}
422 <=> $::Types{$a}->{'size'} } @sorted_types;
424 foreach my $type (@sorted_types) {
425 last if ($line_count++ == $::opt_showtype);
427 my $type_data = $::Types{$type};
428 $bytes_printed_tally += $type_data->{'size'};
430 if ($type_data->{'count'}) {
431 printf "%.2f%% ", $type_data->{'size'} * 100.0/$::TotalSize;
432 print $type_data->{'size'},
433 "\t(",
434 $type_data->{'min'}, "/",
435 int($type_data->{'size'} / $type_data->{'count'}),"/",
436 $type_data->{'max'}, ")";
437 print "\t", $type_data->{'count'},
438 " x ";
440 print $type;
442 if ($type_data->{'swept_in'}) {
443 print ", $type_data->{'swept_in'} sub-objs absorbed";
445 if ($type_data->{'swept'}) {
446 print ", $type_data->{'swept'} swept away";
448 if ($type_data->{'overlap_count'}) {
449 print ", $type_data->{'overlap_count'} range overlaps";
451 if ($type_data->{'dup_addr_count'}) {
452 print ", $type_data->{'dup_addr_count'} duplicated addresses";
455 print "\n" ;
456 if (defined $type_data->{'sweep_details_size'}) {
457 my $sizes = $type_data->{'sweep_details_size'};
458 my $counts = $type_data->{'sweep_details_count'};
459 my @swept_types = sort {$sizes->{$b} <=> $sizes->{$a}} keys (%{$sizes});
461 for my $type (@swept_types) {
462 printf " %.2f%% ", $sizes->{$type} * 100.0/$::TotalSize;
463 print "$sizes->{$type} (", int($sizes->{$type}/$counts->{$type}) , ") $counts->{$type} x $type\n";
465 print " ---------------\n";
468 if ($bytes_printed_tally != $::TotalSize) {
469 printf "%.2f%% ", ($::TotalSize- $bytes_printed_tally) * 100.0/$::TotalSize;
470 print $::TotalSize - $bytes_printed_tally, "\t not shown due to truncation of type list\n";
471 print "Currently only data on $::opt_showtype types are displayed, due to command \n",
472 "line argument '--showtype=$::opt_showtype'\n\n";
477 #----------------------------------------------------------------------
479 # Check for duplicate address ranges is Objects table, and
480 # create list of sorted addresses for doing pointer-chasing
482 sub validate_address_ranges() {
483 # Build sorted list of address for validating interior pointers
484 @::SortedAddresses = sort {$a <=> $b} keys %::Objects;
486 # Validate non-overlap of memory
487 my $prev_addr_end = -1;
488 my $prev_addr = -1;
489 my $index = 0;
490 my $overlap_tally = 0; # overlapping object memory
491 my $unused_tally = 0; # unused memory between blocks
492 while ($index <= $#::SortedAddresses) {
493 my $address = $::SortedAddresses[$index];
494 if ($prev_addr_end > $address) {
495 print "Object overlap from $::Objects{$prev_addr}->{'type'}:$prev_addr-$prev_addr_end into";
496 my $test_index = $index;
497 my $prev_addr_overlap_tally = 0;
499 while ($test_index <= $#::SortedAddresses) {
500 my $test_address = $::SortedAddresses[$test_index];
501 last if ($prev_addr_end < $test_address);
502 print " $::Objects{$test_address}->{'type'}:$test_address";
504 $::Objects{$prev_addr}->{'overlap_count'}++;
505 $::Objects{$test_address}->{'overlap_count'}++;
506 my $overlap = $prev_addr_end - $test_address;
507 if ($overlap > $::Objects{$test_address}->{'size'}) {
508 $overlap = $::Objects{$test_address}->{'size'};
510 print "($overlap bytes)";
511 $prev_addr_overlap_tally += $overlap;
513 $test_index++;
515 print " [total $prev_addr_overlap_tally bytes]";
516 $overlap_tally += $prev_addr_overlap_tally;
517 print "\n";
520 $prev_addr = $address;
521 $prev_addr_end = $prev_addr + $::Objects{$prev_addr}->{'size'} - 1;
522 $index++;
523 } #end while
524 if ($overlap_tally) {
525 print "Total overlap of $overlap_tally bytes\n";
529 #----------------------------------------------------------------------
531 # Evaluate sizes of interobject spacing (fragmentation loss?)
532 # Gather the sizes into histograms for analysis
533 # This function assumes a sorted list of addresses is present globally
535 sub generate_and_print_unused_memory_histogram() {
536 print "\nInterobject spacing (fragmentation waste) Statistics\n";
537 if ($::opt_fragment <= 1) {
538 print "Statistics are not being gathered. Use '--fragment=10' to get stats\n";
539 return;
541 print "Ratio of histogram buckets will be a factor of $::opt_fragment\n";
543 my $prev_addr_end = -1;
544 my $prev_addr = -1;
545 my $index = 0;
547 my @fragment_count;
548 my @fragment_tally;
549 my $power;
550 my $bucket_size;
552 my $max_power = 0;
554 my $tally_sizes = 0;
556 while ($index <= $#::SortedAddresses) {
557 my $address = $::SortedAddresses[$index];
559 my $unused = $address - $prev_addr_end;
561 # handle overlaps gracefully
562 if ($unused < 0) {
563 $unused = 0;
566 $power = 0;
567 $bucket_size = 1;
568 while ($bucket_size < $unused) {
569 $bucket_size *= $::opt_fragment;
570 $power++;
572 $fragment_count[$power]++;
573 $fragment_tally[$power] += $unused;
574 if ($power > $max_power) {
575 $max_power = $power;
577 my $size = $::Objects{$address}->{'size'};
578 $tally_sizes += $size;
579 $prev_addr_end = $address + $size - 1;
580 $index++;
584 $power = 0;
585 $bucket_size = 1;
586 print "Basic gap histogram is (max_size:count):\n";
587 while ($power <= $max_power) {
588 if (! defined $fragment_count[$power]) {
589 $fragment_count[$power] = $fragment_tally[$power] = 0;
591 printf " %.1f:", $bucket_size;
592 print $fragment_count[$power];
593 $power++;
594 $bucket_size *= $::opt_fragment;
596 print "\n";
598 print "Summary gap analysis:\n";
600 $power = 0;
601 $bucket_size = 1;
602 my $tally = 0;
603 my $count = 0;
604 while ($power <= $max_power) {
605 $count += $fragment_count[$power];
606 $tally += $fragment_tally[$power];
607 print "$count gaps, totaling $tally bytes, were under ";
608 printf "%.1f bytes each", $bucket_size;
609 if ($count) {
610 printf ", for an average of %.1f bytes per gap", $tally/$count, ;
612 print "\n";
613 $power++;
614 $bucket_size *= $::opt_fragment;
617 print "Total allocation was $tally_sizes bytes, or ";
618 printf "%.0f bytes per allocation block\n\n", $tally_sizes/($count+1);
622 #----------------------------------------------------------------------
624 # Now thread the parents and children together by looking through the
625 # slots for each object.
627 sub create_parent_links(){
628 my $min_addr = $::SortedAddresses[0];
629 my $max_addr = $::SortedAddresses[ $#::SortedAddresses]; #allow one beyond each object
630 $max_addr += $::Objects{$max_addr}->{'size'};
632 print "Viable addresses range from $min_addr to $max_addr for a total of ",
633 $max_addr-$min_addr, " bytes\n\n";
635 # Gather stats as we try to convert slots to children
636 my $slot_count = 0; # total slots examined
637 my $fixed_addr_count = 0; # slots into interiors that were adjusted
638 my $parent_child_count = 0; # Number of parent-child links
639 my $child_count = 0; # valid slots, discounting sibling twins
640 my $child_dup_count = 0; # number of duplicate child pointers
641 my $self_pointer_count = 0; # count of discarded self-pointers
643 foreach my $parent (keys %::Objects) {
644 # We'll collect a list of this parent object's children
645 # by iterating through its slots.
646 my @children;
647 my %children_hash;
648 my $self_pointer = 0;
650 my @slots = @{$::Objects{$parent}->{'slots'}};
651 $slot_count += $#slots + 1;
652 SLOT: foreach my $child (@slots) {
654 # We only care about pointers that refer to other objects
655 if (! defined $::Objects{$child}) {
656 # check to see if we are an interior pointer
658 # Punt if we are completely out of range
659 next SLOT unless ($max_addr >= $child &&
660 $child >= $min_addr);
662 # Do binary search to find object below this address
663 my ($min_index, $beyond_index) = (0, $#::SortedAddresses + 1);
664 my $test_index;
665 while ($min_index !=
666 ($test_index = int (($beyond_index+$min_index)/2))) {
667 if ($child >= $::SortedAddresses[$test_index]) {
668 $min_index = $test_index;
669 } else {
670 $beyond_index = $test_index;
673 # See if pointer is within extent of this object
674 my $address = $::SortedAddresses[$test_index];
675 next SLOT unless ($child <
676 $address + $::Objects{$address}->{'size'});
678 # Make adjustment so we point to the actual child precisely
679 $child = $address;
680 $fixed_addr_count++;
683 if ($child == $parent) {
684 $self_pointer_count++;
685 next SLOT; # Discard self-pointers
688 # Avoid creating duplicate child-parent links
689 if (! defined $children_hash{$child}) {
690 $parent_child_count++;
691 # Add the parent to the child's list of parents
692 my $parents = $::Objects{$child}->{'parents'};
693 if (! $parents) {
694 $parents = $::Objects{$child}->{'parents'} = [];
697 $parents->[scalar(@$parents)] = $parent;
699 # Add the child to the parent's list of children
700 $children_hash{$child} = 1;
701 } else {
702 $child_dup_count++;
705 @children = keys %children_hash;
706 # Track tally of unique children linked
707 $child_count += $#children + 1;
709 $::Objects{$parent}->{'children'} = \@children;
711 if (! @children) {
712 $::Leafs[$#::Leafs + 1] = $parent;
715 print "Scanning $#::SortedAddresses objects, we found $parent_child_count parents-to-child connections by chasing $slot_count pointers.\n",
716 "This required $fixed_addr_count interior pointer fixups, skipping $child_dup_count duplicate pointers, ",
717 "and $self_pointer_count self pointers\nAlso discarded ",
718 $slot_count - $parent_child_count -$self_pointer_count - $child_dup_count,
719 " out-of-range pointers\n\n";
723 #----------------------------------------------------------------------
724 # For every leaf, if a leaf has only one parent, then sweep the memory
725 # cost into the parent from the leaf
726 sub sweep_leaf_memory () {
727 my $sweep_count = 0;
728 my $leaf_counter = 0;
729 LEAF: while ($leaf_counter <= $#::Leafs) {
730 my $leaf_addr = $::Leafs[$leaf_counter++];
731 my $leaf_obj = $::Objects{$leaf_addr};
732 my $parents = $leaf_obj->{'parents'};
734 next LEAF if (! defined($parents) || 1 != scalar(@$parents));
736 # We have only one parent, so we'll try to sweep upwards
737 my $parent_addr = @$parents[0];
738 my $parent_obj = $::Objects{$parent_addr};
740 # watch out for self-pointers
741 next LEAF if ($parent_addr == $leaf_addr);
743 if ($::opt_detail) {
744 foreach my $obj ($parent_obj, $leaf_obj) {
745 if (!defined $obj->{'original_size'}) {
746 $obj->{'original_size'} = $obj->{'size'};
749 if (defined $leaf_obj->{'sweep_details'}) {
750 if (defined $parent_obj->{'sweep_details'}) { # merge details
751 foreach my $swept_obj (keys (%{$leaf_obj->{'sweep_details'}})) {
752 %{$parent_obj->{'sweep_details'}}->{$swept_obj} =
753 %{$leaf_obj->{'sweep_details'}}->{$swept_obj};
755 } else { # No parent info
756 $parent_obj->{'sweep_details'} = \%{$leaf_obj->{'sweep_details'}};
758 delete $leaf_obj->{'sweep_details'};
759 } else { # no leaf detail
760 if (!defined $parent_obj->{'sweep_details'}) {
761 $parent_obj->{'sweep_details'} = {};
764 %{$parent_obj->{'sweep_details'}}->{$leaf_addr} = $leaf_obj->{'original_size'};
767 $parent_obj->{'size'} += $leaf_obj->{'size'};
768 $leaf_obj->{'size'} = 0;
770 if (defined ($leaf_obj->{'swept_in'})) {
771 $parent_obj->{'swept_in'} += $leaf_obj->{'swept_in'};
772 $leaf_obj->{'swept_in'} = 0; # sweep has been handed off to parent
774 $parent_obj->{'swept_in'} ++; # tally swept in leaf_obj
776 $sweep_count++;
778 # See if we created another leaf
779 my $consumed_children = $parent_obj->{'consumed'}++;
780 my @children = $parent_obj->{'children'};
781 if ($consumed_children == $#children) {
782 $::Leafs[$#::Leafs + 1] = @$parents[0];
785 print "Processed ", $leaf_counter, " leaves sweeping memory to parents in ", $sweep_count, " objects\n";
789 #----------------------------------------------------------------------
791 # Subdivide the types of objects that are in our "expand" list
792 # List types that should be sub-divided based on parents, and possibly
793 # children
794 # The argument supplied is a hash table with keys selecting types that
795 # need to be "refined" by including the types of the parent objects,
796 # and (when we are desparate) the types of the children objects.
798 sub expand_type_names($) {
799 my %TypeExpand = %{$_[0]};
801 my @retype; # array of addrs that get extended type names
802 foreach my $child (keys %::Objects) {
803 my $child_obj = $::Objects{$child};
804 next unless (defined ($TypeExpand{$child_obj->{'type'}}));
806 foreach my $relation ('parents','children') {
807 my $relatives = $child_obj->{$relation};
808 next unless defined @$relatives;
810 # Sort out the names of the types of the relatives
811 my %names;
812 foreach my $relative (@$relatives) {
813 %names->{$::Objects{$relative}->{'type'}} = 1;
815 my $related_type_names = join(',' , sort(keys(%names)));
818 $child_obj->{'name' . $relation} = $related_type_names;
820 # Don't bother with children if we have significant parent types
821 last if (!defined ($TypeExpand{$related_type_names}));
823 $retype[$#retype + 1] = $child;
826 # Revisit all addresses we've marked
827 foreach my $child (@retype) {
828 my $child_obj = $::Objects{$child};
829 $child_obj->{'type'} = $TypeExpand{$child_obj->{'type'}};
830 my $extended_type = $child_obj->{'namechildren'};
831 if (defined $extended_type) {
832 $child_obj->{'type'}.= "->(" . $extended_type . ")";
833 delete ($child_obj->{'namechildren'});
835 $extended_type = $child_obj->{'nameparents'};
836 if (defined $extended_type) {
837 $child_obj->{'type'} = "(" . $extended_type . ")->" . $::Objects{$child}->{'type'};
838 delete ($child_obj->{'nameparents'});
843 #----------------------------------------------------------------------
845 # Print out a type histogram
847 sub print_type_histogram() {
848 load_type_table();
849 print_type_table();
850 print "\n\n";
854 #----------------------------------------------------------------------
855 # Provide a nice summary of the types during the process
856 validate_address_ranges();
857 create_parent_links();
859 print "\nBasic memory use histogram is:\n";
860 print_type_histogram();
862 generate_and_print_unused_memory_histogram();
864 sweep_leaf_memory ();
865 print "After doing basic leaf-sweep processing of instances:\n";
866 print_type_histogram();
869 foreach my $typename (@::opt_typedivide) {
870 my %expansion_table;
871 $expansion_table{$typename} = $typename;
872 expand_type_names(\%expansion_table);
873 print "After subdividing <$typename> based on inbound (and somtimes outbound) pointers:\n";
874 print_type_histogram();
878 exit(); # Don't bother with SCCs yet.
881 #----------------------------------------------------------------------
883 # Determine objects that entrain equivalent sets, using the strongly
884 # connected component algorithm from Cormen, Leiserson, and Rivest,
885 # ``An Introduction to Algorithms'', MIT Press 1990, pp. 488-493.
887 sub compute_post_order($$$) {
888 # This routine produces a post-order of the call graph (what CLR call
889 # ``ordering the nodes by f[u]'')
890 my ($parent, $visited, $finish) = @_;
892 # Bail if we've already seen this node
893 return if $visited->{$parent};
895 # We have now!
896 $visited->{$parent} = 1;
898 # Walk the children
899 my $children = $::Objects{$parent}->{'children'};
901 foreach my $child (@$children) {
902 compute_post_order($child, $visited, $finish);
905 # Now that we've walked all the kids, we can append the parent to
906 # the post-order
907 @$finish[scalar(@$finish)] = $parent;
910 sub compute_equivalencies($$$) {
911 # This routine recursively computes equivalencies by walking the
912 # transpose of the callgraph.
913 my ($child, $table, $equivalencies) = @_;
915 # Bail if we've already seen this node
916 return if $table->{$child};
918 # Otherwise, append ourself to the list of equivalencies...
919 @$equivalencies[scalar(@$equivalencies)] = $child;
921 # ...and note our other equivalents in the table
922 $table->{$child} = $equivalencies;
924 my $parents = $::Objects{$child}->{'parents'};
926 foreach my $parent (@$parents) {
927 compute_equivalencies($parent, $table, $equivalencies);
931 sub compute_equivalents() {
932 # Here's the strongly connected components algorithm. (Step 2 has been
933 # done implictly by our object graph construction.)
934 my %visited;
935 my @finish;
937 # Step 1. Compute a post-ordering of the object graph
938 foreach my $parent (keys %::Objects) {
939 compute_post_order($parent, \%visited, \@finish);
942 # Step 3. Traverse the transpose of the object graph in reverse
943 # post-order, collecting vertices into %equivalents
944 my %equivalents;
945 foreach my $child (reverse @finish) {
946 compute_equivalencies($child, \%equivalents, []);
949 # Now, we'll trim the %equivalents table, arbitrarily removing
950 # ``redundant'' entries.
951 EQUIVALENT: foreach my $node (keys %equivalents) {
952 my $equivalencies = $equivalents{$node};
953 next EQUIVALENT unless $equivalencies;
955 foreach my $equivalent (@$equivalencies) {
956 delete $equivalents{$equivalent} unless $equivalent == $node;
960 # Note the equivalent objects in a way that will yield the most
961 # interesting order as we do depth-first traversal later to
962 # output them.
963 ROOT: foreach my $equivalent (reverse @finish) {
964 next ROOT unless $equivalents{$equivalent};
965 $::Equivalents[$#::Equivalents + 1] = $equivalent;
967 # XXX Lame! Should figure out function refs.
968 $::Objects{$equivalent}->{'entrained-size'} = 0;
972 # Do it!
973 compute_equivalents();
976 #----------------------------------------------------------------------
978 # Compute the size of each node's transitive closure.
980 sub compute_entrained($$) {
981 my ($parent, $visited) = @_;
983 $visited->{$parent} = 1;
985 $::Objects{$parent}->{'entrained-size'} = $::Objects{$parent}->{'size'};
987 my $children = $::Objects{$parent}->{'children'};
988 CHILD: foreach my $child (@$children) {
989 next CHILD if $visited->{$child};
991 compute_entrained($child, $visited);
992 $::Objects{$parent}->{'entrained-size'} += $::Objects{$child}->{'entrained-size'};
996 if (! $::opt_noentrained) {
997 my %visited;
999 PARENT: foreach my $parent (@::Equivalents) {
1000 next PARENT if $visited{$parent};
1001 compute_entrained($parent, \%visited);
1006 #----------------------------------------------------------------------
1008 # Converts a shared library and an address into a file and line number
1009 # using a bunch of addr2line processes.
1011 sub addr2line($$) {
1012 my ($dso, $addr) = @_;
1014 # $::Addr2Lines is a global table that maps a DSO's name to a pair
1015 # of filehandles that are talking to an addr2line process.
1016 my $fhs = $::Addr2Lines{$dso};
1017 if (! $fhs) {
1018 if (!(-r $dso)) {
1019 # bogus filename (that happens sometimes), so bail
1020 return { 'dso' => $dso, 'addr' => $addr };
1022 my ($in, $out) = (new FileHandle, new FileHandle);
1023 open2($in, $out, "addr2line --exe=$dso") || die "unable to open addr2line --exe=$dso";
1024 $::Addr2Lines{$dso} = $fhs = { 'in' => $in, 'out' => $out };
1027 # addr2line takes a hex address as input...
1028 $fhs->{'out'}->print($addr . "\n");
1030 # ...and'll return file:lineno as output
1031 if ($fhs->{'in'}->getline() =~ /([^:]+):(.+)/) {
1032 return { 'file' => $1, 'line' => $2 };
1034 else {
1035 return { 'dso' => $dso, 'addr' => $addr };
1040 #----------------------------------------------------------------------
1042 # Dump the objects, using a depth-first traversal.
1044 sub dump_objects($$$) {
1045 my ($parent, $visited, $depth) = @_;
1047 # Have we already seen this?
1048 my $already_visited = $visited->{$parent};
1049 return if ($depth == 0 && $already_visited);
1051 if (! $already_visited) {
1052 $visited->{$parent} = 1;
1053 $::Total += $::Objects{$parent}->{'size'};
1056 my $parententry = $::Objects{$parent};
1058 # Make an ``object'' div, which'll contain an ``object'' span, two
1059 # ``toggle'' spans, an invisible ``stack'' div, and the invisible
1060 # ``children'' div.
1061 print "<div class='object'>";
1063 if ($already_visited) {
1064 print "<a href='#$parent'>";
1066 else {
1067 print "<span id='$parent' class='object";
1068 print " root" if $depth == 0;
1069 print "'>";
1072 printf "0x%x&lt;%s&gt;[%d]", $parent, $parententry->{'type'}, $parententry->{'size'};
1074 if ($already_visited) {
1075 print "</a>";
1076 goto DONE;
1079 if ($depth == 0) {
1080 print "($parententry->{'entrained-size'})"
1081 if $parententry->{'entrained-size'};
1083 print "&nbsp;<span class='toggle' onclick='toggleDisplay(this.parentNode.nextSibling.nextSibling);'>Children</span>"
1084 if @{$parententry->{'children'}} > 0;
1087 if (($depth == 0 || !$::opt_nochildstacks) && !$::opt_nostacks) {
1088 print "&nbsp;<span class='toggle' onclick='toggleDisplay(this.parentNode.nextSibling);'>Stack</span>";
1091 print "</span>";
1093 # Print stack traces
1094 print "<div class='stack'>\n";
1096 if (($depth == 0 || !$::opt_nochildstacks) && !$::opt_nostacks) {
1097 my $depth = $::opt_depth;
1099 FRAME: foreach my $frame (@{$parententry->{'stack'}}) {
1100 # Only go as deep as they've asked us to.
1101 last FRAME unless --$depth >= 0;
1103 # Stack frames look like ``mangled_name[dso address]''
1104 $frame =~ /([^\]]+)\[(.*) \+0x([0-9A-Fa-f]+)\]/;
1106 # Convert address to file and line number
1107 my $mangled = $1;
1108 my $result = addr2line($2, $3);
1110 if ($result->{'file'}) {
1111 # It's mozilla source! Clean up refs to dist/include
1112 if (($result->{'file'} =~ s/.*\.\.\/\.\.\/dist\/include\//http:\/\/bonsai.mozilla.org\/cvsguess.cgi\?file=/) ||
1113 ($result->{'file'} =~ s/.*\/mozilla/http:\/\/bonsai.mozilla.org\/cvsblame.cgi\?file=mozilla/)) {
1114 my $prevline = $result->{'line'} - 10;
1115 print "<a target=\"lxr_source\" href=\"$result->{'file'}\&mark=$result->{'line'}#$prevline\">$mangled</a><br>\n";
1117 else {
1118 print "$mangled ($result->{'file'}, line $result->{'line'})<br>\n";
1121 else {
1122 print "$result->{'dso'} ($result->{'addr'})<br>\n";
1128 print "</div>";
1130 # Recurse to children
1131 if (@{$parententry->{'children'}} >= 0) {
1132 print "<div class='children'>\n" if $depth == 0;
1134 foreach my $child (@{$parententry->{'children'}}) {
1135 dump_objects($child, $visited, $depth + 1);
1138 print "</div>" if $depth == 0;
1141 DONE:
1142 print "</div>\n";
1146 #----------------------------------------------------------------------
1148 # Do the output.
1151 # Force flush on STDOUT. We get funky output unless we do this.
1152 $| = 1;
1154 # Header
1155 print "<html>
1156 <head>
1157 <title>Object Graph</title>
1158 <style type='text/css'>
1159 body { font: medium monospace; background-color: white; }
1161 /* give nested div's some margins to make it look like a tree */
1162 div.children > div.object { margin-left: 1em; }
1163 div.object > div.object { margin-left: 1em; }
1165 /* Indent stacks, too */
1166 div.object > div.stack { margin-left: 3em; }
1168 /* apply font decorations to special ``object'' spans */
1169 span.object { font-weight: bold; color: darkgrey; }
1170 span.object.root { color: black; }
1172 /* hide ``stack'' divs by default; JS will show them */
1173 div.stack { display: none; }
1175 /* hide ``children'' divs by default; JS will show them */
1176 div.children { display: none; }
1178 /* make ``toggle'' spans look like links */
1179 span.toggle { color: blue; text-decoration: underline; cursor: pointer; }
1180 span.toggle:active { color: red; }
1181 </style>
1182 <script language='JavaScript'>
1183 function toggleDisplay(element)
1185 element.style.display = (element.style.display == 'block') ? 'none' : 'block';
1187 </script>
1188 </head>
1189 <body>
1193 # Body. Display ``roots'', sorted by the amount of memory they
1194 # entrain. Because of the way we've sorted @::Equivalents, we should
1195 # get a nice ordering that sorts things with a lot of kids early
1196 # on. This should yield a fairly "deep" depth-first traversal, with
1197 # most of the objects appearing as children.
1199 # XXX I sure hope that Perl implements a stable sort!
1200 my %visited;
1202 foreach my $parent (sort { $::Objects{$b}->{'entrained-size'}
1203 <=> $::Objects{$a}->{'entrained-size'} }
1204 @::Equivalents) {
1205 dump_objects($parent, \%visited, 0);
1206 print "\n";
1210 # Footer
1211 print "<br> $::Total total bytes\n" if $::Total;
1212 print "</body>
1213 </html>