tools/rb/make-tree.pl

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