CLOSED TREE: TraceMonkey merge head. (a=blockers)

[mozilla-central.git] / tools / trace-malloc / leak-soup.pl

#!/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};



\f
#----------------------------------------------------------------------
#
# 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";
        }
    }
}

\f
#----------------------------------------------------------------------
#
# 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;
  }
}

\f
#----------------------------------------------------------------------
#
# Read input
#
init_stack_based_type_refinement();
read_boehm;


\f
#----------------------------------------------------------------------
#
# 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;
        }
    }
}

\f
#----------------------------------------------------------------------
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";
    }

}
\f
#----------------------------------------------------------------------
#
# 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";
    }
}
\f
#----------------------------------------------------------------------
#
# 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);
    
}
\f
#----------------------------------------------------------------------
#
# 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";
}

\f
#----------------------------------------------------------------------
# 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";
}

\f
#----------------------------------------------------------------------
#
# 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'});
        }
    }
}
\f
#----------------------------------------------------------------------
#
# Print out a type histogram

sub print_type_histogram() {
    load_type_table();
    print_type_table();
    print "\n\n";
}

\f
#----------------------------------------------------------------------
# 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.

\f
#----------------------------------------------------------------------
#
# 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();

\f
#----------------------------------------------------------------------
#
# 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);
  }
}

\f
#----------------------------------------------------------------------
#
# 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 };
    }
}

\f
#----------------------------------------------------------------------
#
# 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";
}

\f
#----------------------------------------------------------------------
#
# 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>
";