michael@0: #!/usr/bin/perl -w
michael@0: #
michael@0: # This Source Code Form is subject to the terms of the Mozilla Public
michael@0: # License, v. 2.0. If a copy of the MPL was not distributed with this
michael@0: # file, You can obtain one at http://mozilla.org/MPL/2.0/.
michael@0: 
michael@0: use 5.004;
michael@0: use strict;
michael@0: use Getopt::Long;
michael@0: 
michael@0: $::opt_prune_depth = 0;
michael@0: $::opt_subtree_size = 0;
michael@0: $::opt_reverse = 0;
michael@0: 
michael@0: # GetOption will create $opt_object & $opt_exclude, so ignore the
michael@0: # warning that gets spit out about those vbls.
michael@0: GetOptions("object=s", "exclude=s", "comptrs=s", "ignore-balanced", "subtree-size=i", "prune-depth=i",
michael@0:             "collapse-to-method", "collapse-to-class", "old-style", "reverse");
michael@0: 
michael@0: $::opt_object ||
michael@0:      die qq{
michael@0: usage: leak.pl < logfile
michael@0:   --object <obj>         The address of the object to examine (required)
michael@0:   --exclude <file>       Exclude routines listed in <file>
michael@0:   --comptrs <file>       Subtract all the data in the balanced COMPtr log <file>
michael@0:   --ignore-balanced      Ignore balanced subtrees
michael@0:   --subtree-size <n>     Print subtrees with more than <n> nodes separately
michael@0:   --prune-depth <depth>  Prune the tree to <depth>
michael@0:   --collapse-to-method   Aggregate data by method
michael@0:   --collapse-to-class    Aggregate data by class (subsumes --collapse-to-method)
michael@0:   --reverse              Reverse call stacks, showing leaves first
michael@0:   --old-style            Old-style formatting
michael@0: };
michael@0: 
michael@0: $::opt_prune_depth = 0 if $::opt_prune_depth < 0;
michael@0: $::opt_subtree_size = 0 if $::opt_subtree_size < 0;
michael@0: 
michael@0: warn "object $::opt_object\n";
michael@0: warn "ignoring balanced subtrees\n" if $::opt_ignore_balanced;
michael@0: warn "prune depth $::opt_prune_depth\n" if $::opt_prune_depth;
michael@0: warn "collapsing to class\n" if $::opt_collapse_to_class;
michael@0: warn "collapsing to method\n" if $::opt_collapse_to_method && !$::opt_collapse_to_class;
michael@0: warn "reversing call stacks\n" if $::opt_reverse;
michael@0: 
michael@0: 
michael@0: # The 'excludes' are functions that, if detected in a particular call
michael@0: # stack, will cause the _entire_ call stack to be ignored. You might,
michael@0: # for example, explicitly exclude two functions that have a matching
michael@0: # AddRef/Release pair.
michael@0: 
michael@0: my %excludes;
michael@0: 
michael@0: if ($::opt_exclude) {
michael@0:      open(EXCLUDE, "<".$::opt_exclude)
michael@0:          || die "unable to open $::opt_exclude";
michael@0:  
michael@0:      while (<EXCLUDE>) {
michael@0:          chomp $_;
michael@0:          warn "excluding $_\n";
michael@0:          $excludes{$_} = 1;
michael@0:      }
michael@0: }
michael@0: 
michael@0: # Each entry in the tree rooted by callGraphRoot contains the following:
michael@0: #   #name#      This call's name+offset string
michael@0: #   #refcount#  The net reference count of this call
michael@0: #   #label#     The label used for this subtree; only defined for labeled nodes
michael@0: #   #children#  List of children in alphabetical order
michael@0: # zero or more children indexed by method name+offset strings.
michael@0: 
michael@0: my $callGraphRoot;
michael@0: $callGraphRoot = { '#name#' => '.root', '#refcount#' => 'n/a' };
michael@0: 
michael@0: # The 'imbalance' is a gross count of how balanced a particular
michael@0: # callsite is. It is used to prune away callsites that are detected to
michael@0: # be balanced; that is, that have matching AddRef/Release() pairs.
michael@0: 
michael@0: my %imbalance;
michael@0: $imbalance{'.root'} = 'n/a';
michael@0: 
michael@0: # The main read loop.
michael@0: 
michael@0: sub read_data($$$) {
michael@0:      my ($INFILE, $plus, $minus) = @_;
michael@0: 
michael@0:      LINE: while (<$INFILE>) {
michael@0:           next LINE if (! /^</);
michael@0:           my @fields = split(/ /, $_);
michael@0:      
michael@0:           my $class = shift(@fields);
michael@0:           my $obj   = shift(@fields);
michael@0:           my $sno   = shift(@fields);
michael@0:           next LINE unless ($obj eq $::opt_object);
michael@0:      
michael@0:           my $op  = shift(@fields);
michael@0:           next LINE unless ($op eq $plus || $op eq $minus);
michael@0:      
michael@0:           my $cnt = shift(@fields);
michael@0:      
michael@0:           # Collect the remaining lines to create a stack trace.
michael@0:           my @stack;
michael@0:           CALLSITE: while (<$INFILE>) {
michael@0:               chomp;
michael@0:               last CALLSITE if (/^$/);
michael@0:               $stack[++$#stack] = $_;
michael@0:           }
michael@0:      
michael@0:           # Reverse the remaining fields to produce the call stack, with the
michael@0:           # oldest frame at the front of the array.
michael@0:           if (! $::opt_reverse) {
michael@0:               @stack = reverse(@stack);
michael@0:           }
michael@0:      
michael@0:           my $call;
michael@0:      
michael@0:           # If any of the functions in the stack are supposed to be excluded,
michael@0:           # march on to the next line.
michael@0:           foreach $call (@stack) {
michael@0:               next LINE if exists($excludes{$call});
michael@0:           }
michael@0:      
michael@0:      
michael@0:           # Add the callstack as a path through the call graph, updating
michael@0:           # refcounts at each node.
michael@0:      
michael@0:           my $caller = $callGraphRoot;
michael@0:      
michael@0:           foreach $call (@stack) {
michael@0:      
michael@0:               # Chop the method offset if we're 'collapsing to method' or
michael@0:               # 'collapsing to class'.
michael@0:               $call =~ s/\+0x.*$//g if ($::opt_collapse_to_method || $::opt_collapse_to_class);
michael@0:      
michael@0:               # Chop the method name if we're 'collapsing to class'.
michael@0:               $call =~ s/::.*$//g if ($::opt_collapse_to_class);
michael@0:      
michael@0:               my $site = $caller->{$call};
michael@0:               if (!$site) {
michael@0:                   # This is the first time we've seen this callsite. Add a
michael@0:                   # new entry to the call tree.
michael@0:      
michael@0:                   $site = { '#name#' => $call, '#refcount#' => 0 };
michael@0:                   $caller->{$call} = $site;
michael@0:               }
michael@0:      
michael@0:               if ($op eq $plus) {
michael@0:                   ++($site->{'#refcount#'});
michael@0:                   ++($imbalance{$call});
michael@0:               } elsif ($op eq $minus) {
michael@0:                   --($site->{'#refcount#'});
michael@0:                   --($imbalance{$call});
michael@0:               } else {
michael@0:                   die "Bad operation $op";
michael@0:               }
michael@0:      
michael@0:               $caller = $site;
michael@0:           }
michael@0:      }
michael@0: }
michael@0: 
michael@0: read_data(*STDIN, "AddRef", "Release");
michael@0: 
michael@0: if ($::opt_comptrs) {
michael@0:      warn "Subtracting comptr log ". $::opt_comptrs . "\n";
michael@0:      open(COMPTRS, "<".$::opt_comptrs)
michael@0:          || die "unable to open $::opt_comptrs";
michael@0: 
michael@0:      # read backwards to subtract
michael@0:      read_data(*COMPTRS, "nsCOMPtrRelease", "nsCOMPtrAddRef");
michael@0: }
michael@0: 
michael@0: sub num_alpha {
michael@0:      my ($aN, $aS, $bN, $bS);
michael@0:      ($aN, $aS) = ($1, $2) if $a =~ /^(\d+) (.+)$/;
michael@0:      ($bN, $bS) = ($1, $2) if $b =~ /^(\d+) (.+)$/;
michael@0:      return $a cmp $b unless defined $aN && defined $bN;
michael@0:      return $aN <=> $bN unless $aN == $bN;
michael@0:      return $aS cmp $bS;
michael@0: }
michael@0: 
michael@0: # Given a subtree and its nesting level, return true if that subtree should be pruned.
michael@0: # If it shouldn't be pruned, destructively attempt to prune its children.
michael@0: # Also compute the #children# properties of unpruned nodes.
michael@0: sub prune($$) {
michael@0:      my ($site, $nest) = @_;
michael@0: 
michael@0:      # If they want us to prune the tree's depth, do so here.
michael@0:      return 1 if ($::opt_prune_depth && $nest >= $::opt_prune_depth);
michael@0: 
michael@0:      # If the subtree is balanced, ignore it.
michael@0:      return 1 if ($::opt_ignore_balanced && !$site->{'#refcount#'});
michael@0: 
michael@0:      my $name = $site->{'#name#'};
michael@0: 
michael@0:      # If the symbol isn't imbalanced, then prune here (and warn)
michael@0:      if ($::opt_ignore_balanced && !$imbalance{$name}) {
michael@0:          warn "discarding " . $name . "\n";
michael@0: #         return 1;
michael@0:      }
michael@0: 
michael@0:      my @children;
michael@0:      foreach my $child (sort num_alpha keys(%$site)) {
michael@0:          if (substr($child, 0, 1) ne '#') {
michael@0:              if (prune($site->{$child}, $nest + 1)) {
michael@0:                  delete $site->{$child};
michael@0:              } else {
michael@0:                  push @children, $site->{$child};
michael@0:              }
michael@0:          }
michael@0:      }
michael@0:      $site->{'#children#'} = \@children;
michael@0:      return 0;
michael@0: }
michael@0: 
michael@0: 
michael@0: # Compute the #label# properties of this subtree.
michael@0: # Return the subtree's number of nodes, not counting nodes reachable 
michael@0: # through a labeled node.
michael@0: sub createLabels($) {
michael@0:      my ($site) = @_;
michael@0:      my @children = @{$site->{'#children#'}};
michael@0:      my $nChildren = @children;
michael@0:      my $nDescendants = 0;
michael@0: 
michael@0:      foreach my $child (@children) {
michael@0:          my $childDescendants = createLabels($child);
michael@0:          if ($nChildren > 1 && $childDescendants > $::opt_subtree_size) {
michael@0:              die "Internal error" if defined($child->{'#label#'});
michael@0:              $child->{'#label#'} = "__label__";
michael@0:              $childDescendants = 1;
michael@0:          }
michael@0:          $nDescendants += $childDescendants;
michael@0:      }
michael@0:      return $nDescendants + 1;
michael@0: }
michael@0: 
michael@0: 
michael@0: my $nextLabel = 0;
michael@0: my @labeledSubtrees;
michael@0: 
michael@0: sub list($$$$$) {
michael@0:      my ($site, $nest, $nestStr, $childrenLeft, $root) = @_;
michael@0:      my $label = !$root && $site->{'#label#'};
michael@0: 
michael@0:      # Assign a unique number to the label.
michael@0:      if ($label) {
michael@0:          die unless $label eq "__label__";
michael@0:          $label = "__" . ++$nextLabel . "__";
michael@0:          $site->{'#label#'} = $label;
michael@0:          push @labeledSubtrees, $site;
michael@0:      }
michael@0: 
michael@0:      print $nestStr;
michael@0:      if ($::opt_old_style) {
michael@0:          print $label, " " if $label;
michael@0:          print $site->{'#name#'}, ": bal=", $site->{'#refcount#'}, "\n";
michael@0:      } else {
michael@0:          my $refcount = $site->{'#refcount#'};
michael@0:          my $l = 8 - length $refcount;
michael@0:          $l = 1 if $l < 1;
michael@0:          print $refcount, " " x $l;
michael@0:          print $label, " " if $label;
michael@0:          print $site->{'#name#'}, "\n";
michael@0:      }
michael@0: 
michael@0:      $nestStr .= $childrenLeft && !$::opt_old_style ? "| " : "  ";
michael@0:      if (!$label) {
michael@0:          my @children = @{$site->{'#children#'}};
michael@0:          $childrenLeft = @children;
michael@0:          foreach my $child (@children) {
michael@0:              $childrenLeft--;
michael@0:              list($child, $nest + 1, $nestStr, $childrenLeft);
michael@0:          }
michael@0:      }
michael@0: }
michael@0: 
michael@0: 
michael@0: if (!prune($callGraphRoot, 0)) {
michael@0:      createLabels $callGraphRoot if ($::opt_subtree_size);
michael@0:      list $callGraphRoot, 0, "", 0, 1;
michael@0:      while (@labeledSubtrees) {
michael@0:          my $labeledSubtree = shift @labeledSubtrees;
michael@0:          print "\n------------------------------\n", 
michael@0: $labeledSubtree->{'#label#'}, "\n";
michael@0:          list $labeledSubtree, 0, "", 0, 1;
michael@0:      }
michael@0:      print "\n------------------------------\n" if @labeledSubtrees;
michael@0: }
michael@0: 
michael@0: print qq{
michael@0: Imbalance
michael@0: ---------
michael@0: };
michael@0: 
michael@0: foreach my $call (sort num_alpha keys(%imbalance)) {
michael@0:      print $call . " " . $imbalance{$call} . "\n";
michael@0: }
michael@0: