tools/rb/make-tree.pl

   1 #!/usr/bin/perl -w
   2 #
   3 # This Source Code Form is subject to the terms of the Mozilla Public
   4 # License, v. 2.0. If a copy of the MPL was not distributed with this
   5 # file, You can obtain one at http://mozilla.org/MPL/2.0/.
   6
   7 use 5.004;
   8 use strict;
   9 use Getopt::Long;
  10
  11 $::opt_prune_depth = 0;
  12 $::opt_subtree_size = 0;
  13 $::opt_reverse = 0;
  14
  15 # GetOption will create $opt_object & $opt_exclude, so ignore the
  16 # warning that gets spit out about those vbls.
  17 GetOptions("object=s", "exclude=s", "comptrs=s", "ignore-balanced", "subtree-size=i", "prune-depth=i",
  18             "collapse-to-method", "collapse-to-class", "old-style", "reverse");
  19
  20 $::opt_object ||
  21      die qq{
  22 usage: leak.pl < logfile
  23   --object <obj>         The address of the object to examine (required)
  24   --exclude <file>       Exclude routines listed in <file>
  25   --comptrs <file>       Subtract all the data in the balanced COMPtr log <file>
  26   --ignore-balanced      Ignore balanced subtrees
  27   --subtree-size <n>     Print subtrees with more than <n> nodes separately
  28   --prune-depth <depth>  Prune the tree to <depth>
  29   --collapse-to-method   Aggregate data by method
  30   --collapse-to-class    Aggregate data by class (subsumes --collapse-to-method)
  31   --reverse              Reverse call stacks, showing leaves first
  32   --old-style            Old-style formatting
  33 };
  34
  35 $::opt_prune_depth = 0 if $::opt_prune_depth < 0;
  36 $::opt_subtree_size = 0 if $::opt_subtree_size < 0;
  37
  38 warn "object $::opt_object\n";
  39 warn "ignoring balanced subtrees\n" if $::opt_ignore_balanced;
  40 warn "prune depth $::opt_prune_depth\n" if $::opt_prune_depth;
  41 warn "collapsing to class\n" if $::opt_collapse_to_class;
  42 warn "collapsing to method\n" if $::opt_collapse_to_method && !$::opt_collapse_to_class;
  43 warn "reversing call stacks\n" if $::opt_reverse;
  44
  45
  46 # The 'excludes' are functions that, if detected in a particular call
  47 # stack, will cause the _entire_ call stack to be ignored. You might,
  48 # for example, explicitly exclude two functions that have a matching
  49 # AddRef/Release pair.
  50
  51 my %excludes;
  52
  53 if ($::opt_exclude) {
  54      open(EXCLUDE, "<".$::opt_exclude)
  55          || die "unable to open $::opt_exclude";
  56
  57      while (<EXCLUDE>) {
  58          chomp $_;
  59          warn "excluding $_\n";
  60          $excludes{$_} = 1;
  61      }
  62 }
  63
  64 # Each entry in the tree rooted by callGraphRoot contains the following:
  65 #   #name#      This call's name+offset string
  66 #   #refcount#  The net reference count of this call
  67 #   #label#     The label used for this subtree; only defined for labeled nodes
  68 #   #children#  List of children in alphabetical order
  69 # zero or more children indexed by method name+offset strings.
  70
  71 my $callGraphRoot;
  72 $callGraphRoot = { '#name#' => '.root', '#refcount#' => 'n/a' };
  73
  74 # The 'imbalance' is a gross count of how balanced a particular
  75 # callsite is. It is used to prune away callsites that are detected to
  76 # be balanced; that is, that have matching AddRef/Release() pairs.
  77
  78 my %imbalance;
  79 $imbalance{'.root'} = 'n/a';
  80
  81 # The main read loop.
  82
  83 sub read_data($$$) {
  84      my ($INFILE, $plus, $minus) = @_;
  85
  86      LINE: while (<$INFILE>) {
  87           next LINE if (! /^</);
  88           my @fields = split(/ /, $_);
  89
  90           my $class = shift(@fields);
  91           my $obj   = shift(@fields);
  92           my $sno   = shift(@fields);
  93           next LINE unless ($obj eq $::opt_object);
  94
  95           my $op  = shift(@fields);
  96           next LINE unless ($op eq $plus || $op eq $minus);
  97
  98           my $cnt = shift(@fields);
  99
 100           # Collect the remaining lines to create a stack trace. We need to
 101           # filter out the frame numbers so that frames that differ only in
 102           # their frame number are considered equivalent. However, we need to
 103           # keep a frame number on each line so that the fix*.py scripts can
 104           # parse the output. So we set the frame number to 0 for every frame.
 105           my @stack;
 106           CALLSITE: while (<$INFILE>) {
 107               chomp;
 108               last CALLSITE if (/^$/);
 109               $_ =~ s/#\d+: /#00: /;    # replace frame number with 0
 110               $stack[++$#stack] = $_;
 111           }
 112
 113           # Reverse the remaining fields to produce the call stack, with the
 114           # oldest frame at the front of the array.
 115           if (! $::opt_reverse) {
 116               @stack = reverse(@stack);
 117           }
 118
 119           my $call;
 120
 121           # If any of the functions in the stack are supposed to be excluded,
 122           # march on to the next line.
 123           foreach $call (@stack) {
 124               next LINE if exists($excludes{$call});
 125           }
 126
 127
 128           # Add the callstack as a path through the call graph, updating
 129           # refcounts at each node.
 130
 131           my $caller = $callGraphRoot;
 132
 133           foreach $call (@stack) {
 134
 135               # Chop the method offset if we're 'collapsing to method' or
 136               # 'collapsing to class'.
 137               $call =~ s/\+0x.*$//g if ($::opt_collapse_to_method || $::opt_collapse_to_class);
 138
 139               # Chop the method name if we're 'collapsing to class'.
 140               $call =~ s/::.*$//g if ($::opt_collapse_to_class);
 141
 142               my $site = $caller->{$call};
 143               if (!$site) {
 144                   # This is the first time we've seen this callsite. Add a
 145                   # new entry to the call tree.
 146
 147                   $site = { '#name#' => $call, '#refcount#' => 0 };
 148                   $caller->{$call} = $site;
 149               }
 150
 151               if ($op eq $plus) {
 152                   ++($site->{'#refcount#'});
 153                   ++($imbalance{$call});
 154               } elsif ($op eq $minus) {
 155                   --($site->{'#refcount#'});
 156                   --($imbalance{$call});
 157               } else {
 158                   die "Bad operation $op";
 159               }
 160
 161               $caller = $site;
 162           }
 163      }
 164 }
 165
 166 read_data(*STDIN, "AddRef", "Release");
 167
 168 if ($::opt_comptrs) {
 169      warn "Subtracting comptr log ". $::opt_comptrs . "\n";
 170      open(COMPTRS, "<".$::opt_comptrs)
 171          || die "unable to open $::opt_comptrs";
 172
 173      # read backwards to subtract
 174      read_data(*COMPTRS, "nsCOMPtrRelease", "nsCOMPtrAddRef");
 175 }
 176
 177 sub num_alpha {
 178      my ($aN, $aS, $bN, $bS);
 179      ($aN, $aS) = ($1, $2) if $a =~ /^(\d+) (.+)$/;
 180      ($bN, $bS) = ($1, $2) if $b =~ /^(\d+) (.+)$/;
 181      return $a cmp $b unless defined $aN && defined $bN;
 182      return $aN <=> $bN unless $aN == $bN;
 183      return $aS cmp $bS;
 184 }
 185
 186 # Given a subtree and its nesting level, return true if that subtree should be pruned.
 187 # If it shouldn't be pruned, destructively attempt to prune its children.
 188 # Also compute the #children# properties of unpruned nodes.
 189 sub prune($$) {
 190      my ($site, $nest) = @_;
 191
 192      # If they want us to prune the tree's depth, do so here.
 193      return 1 if ($::opt_prune_depth && $nest >= $::opt_prune_depth);
 194
 195      # If the subtree is balanced, ignore it.
 196      return 1 if ($::opt_ignore_balanced && !$site->{'#refcount#'});
 197
 198      my $name = $site->{'#name#'};
 199
 200      # If the symbol isn't imbalanced, then prune here (and warn)
 201      if ($::opt_ignore_balanced && !$imbalance{$name}) {
 202          warn "discarding " . $name . "\n";
 203 #         return 1;
 204      }
 205
 206      my @children;
 207      foreach my $child (sort num_alpha keys(%$site)) {
 208          if (substr($child, 0, 1) ne '#') {
 209              if (prune($site->{$child}, $nest + 1)) {
 210                  delete $site->{$child};
 211              } else {
 212                  push @children, $site->{$child};
 213              }
 214          }
 215      }
 216      $site->{'#children#'} = \@children;
 217      return 0;
 218 }
 219
 220
 221 # Compute the #label# properties of this subtree.
 222 # Return the subtree's number of nodes, not counting nodes reachable
 223 # through a labeled node.
 224 sub createLabels($) {
 225      my ($site) = @_;
 226      my @children = @{$site->{'#children#'}};
 227      my $nChildren = @children;
 228      my $nDescendants = 0;
 229
 230      foreach my $child (@children) {
 231          my $childDescendants = createLabels($child);
 232          if ($nChildren > 1 && $childDescendants > $::opt_subtree_size) {
 233              die "Internal error" if defined($child->{'#label#'});
 234              $child->{'#label#'} = "__label__";
 235              $childDescendants = 1;
 236          }
 237          $nDescendants += $childDescendants;
 238      }
 239      return $nDescendants + 1;
 240 }
 241
 242
 243 my $nextLabel = 0;
 244 my @labeledSubtrees;
 245
 246 sub list($$$$$) {
 247      my ($site, $nest, $nestStr, $childrenLeft, $root) = @_;
 248      my $label = !$root && $site->{'#label#'};
 249
 250      # Assign a unique number to the label.
 251      if ($label) {
 252          die unless $label eq "__label__";
 253          $label = "__" . ++$nextLabel . "__";
 254          $site->{'#label#'} = $label;
 255          push @labeledSubtrees, $site;
 256      }
 257
 258      print $nestStr;
 259      if ($::opt_old_style) {
 260          print $label, " " if $label;
 261          print $site->{'#name#'}, ": bal=", $site->{'#refcount#'}, "\n";
 262      } else {
 263          my $refcount = $site->{'#refcount#'};
 264          my $l = 8 - length $refcount;
 265          $l = 1 if $l < 1;
 266          print $refcount, " " x $l;
 267          print $label, " " if $label;
 268          print $site->{'#name#'}, "\n";
 269      }
 270
 271      $nestStr .= $childrenLeft && !$::opt_old_style ? "| " : "  ";
 272      if (!$label) {
 273          my @children = @{$site->{'#children#'}};
 274          $childrenLeft = @children;
 275          foreach my $child (@children) {
 276              $childrenLeft--;
 277              list($child, $nest + 1, $nestStr, $childrenLeft);
 278          }
 279      }
 280 }
 281
 282
 283 if (!prune($callGraphRoot, 0)) {
 284      createLabels $callGraphRoot if ($::opt_subtree_size);
 285      list $callGraphRoot, 0, "", 0, 1;
 286      while (@labeledSubtrees) {
 287          my $labeledSubtree = shift @labeledSubtrees;
 288          print "\n------------------------------\n",
 289 $labeledSubtree->{'#label#'}, "\n";
 290          list $labeledSubtree, 0, "", 0, 1;
 291      }
 292      print "\n------------------------------\n" if @labeledSubtrees;
 293 }
 294
 295 print qq{
 296 Imbalance
 297 ---------
 298 };
 299
 300 foreach my $call (sort num_alpha keys(%imbalance)) {
 301      print $call . " " . $imbalance{$call} . "\n";
 302 }
 303