1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/tools/rb/make-tree.pl Wed Dec 31 06:09:35 2014 +0100
1.3 @@ -0,0 +1,298 @@
1.4 +#!/usr/bin/perl -w
1.5 +#
1.6 +# This Source Code Form is subject to the terms of the Mozilla Public
1.7 +# License, v. 2.0. If a copy of the MPL was not distributed with this
1.8 +# file, You can obtain one at http://mozilla.org/MPL/2.0/.
1.9 +
1.10 +use 5.004;
1.11 +use strict;
1.12 +use Getopt::Long;
1.13 +
1.14 +$::opt_prune_depth = 0;
1.15 +$::opt_subtree_size = 0;
1.16 +$::opt_reverse = 0;
1.17 +
1.18 +# GetOption will create $opt_object & $opt_exclude, so ignore the
1.19 +# warning that gets spit out about those vbls.
1.20 +GetOptions("object=s", "exclude=s", "comptrs=s", "ignore-balanced", "subtree-size=i", "prune-depth=i",
1.21 + "collapse-to-method", "collapse-to-class", "old-style", "reverse");
1.22 +
1.23 +$::opt_object ||
1.24 + die qq{
1.25 +usage: leak.pl < logfile
1.26 + --object <obj> The address of the object to examine (required)
1.27 + --exclude <file> Exclude routines listed in <file>
1.28 + --comptrs <file> Subtract all the data in the balanced COMPtr log <file>
1.29 + --ignore-balanced Ignore balanced subtrees
1.30 + --subtree-size <n> Print subtrees with more than <n> nodes separately
1.31 + --prune-depth <depth> Prune the tree to <depth>
1.32 + --collapse-to-method Aggregate data by method
1.33 + --collapse-to-class Aggregate data by class (subsumes --collapse-to-method)
1.34 + --reverse Reverse call stacks, showing leaves first
1.35 + --old-style Old-style formatting
1.36 +};
1.37 +
1.38 +$::opt_prune_depth = 0 if $::opt_prune_depth < 0;
1.39 +$::opt_subtree_size = 0 if $::opt_subtree_size < 0;
1.40 +
1.41 +warn "object $::opt_object\n";
1.42 +warn "ignoring balanced subtrees\n" if $::opt_ignore_balanced;
1.43 +warn "prune depth $::opt_prune_depth\n" if $::opt_prune_depth;
1.44 +warn "collapsing to class\n" if $::opt_collapse_to_class;
1.45 +warn "collapsing to method\n" if $::opt_collapse_to_method && !$::opt_collapse_to_class;
1.46 +warn "reversing call stacks\n" if $::opt_reverse;
1.47 +
1.48 +
1.49 +# The 'excludes' are functions that, if detected in a particular call
1.50 +# stack, will cause the _entire_ call stack to be ignored. You might,
1.51 +# for example, explicitly exclude two functions that have a matching
1.52 +# AddRef/Release pair.
1.53 +
1.54 +my %excludes;
1.55 +
1.56 +if ($::opt_exclude) {
1.57 + open(EXCLUDE, "<".$::opt_exclude)
1.58 + || die "unable to open $::opt_exclude";
1.59 +
1.60 + while (<EXCLUDE>) {
1.61 + chomp $_;
1.62 + warn "excluding $_\n";
1.63 + $excludes{$_} = 1;
1.64 + }
1.65 +}
1.66 +
1.67 +# Each entry in the tree rooted by callGraphRoot contains the following:
1.68 +# #name# This call's name+offset string
1.69 +# #refcount# The net reference count of this call
1.70 +# #label# The label used for this subtree; only defined for labeled nodes
1.71 +# #children# List of children in alphabetical order
1.72 +# zero or more children indexed by method name+offset strings.
1.73 +
1.74 +my $callGraphRoot;
1.75 +$callGraphRoot = { '#name#' => '.root', '#refcount#' => 'n/a' };
1.76 +
1.77 +# The 'imbalance' is a gross count of how balanced a particular
1.78 +# callsite is. It is used to prune away callsites that are detected to
1.79 +# be balanced; that is, that have matching AddRef/Release() pairs.
1.80 +
1.81 +my %imbalance;
1.82 +$imbalance{'.root'} = 'n/a';
1.83 +
1.84 +# The main read loop.
1.85 +
1.86 +sub read_data($$$) {
1.87 + my ($INFILE, $plus, $minus) = @_;
1.88 +
1.89 + LINE: while (<$INFILE>) {
1.90 + next LINE if (! /^</);
1.91 + my @fields = split(/ /, $_);
1.92 +
1.93 + my $class = shift(@fields);
1.94 + my $obj = shift(@fields);
1.95 + my $sno = shift(@fields);
1.96 + next LINE unless ($obj eq $::opt_object);
1.97 +
1.98 + my $op = shift(@fields);
1.99 + next LINE unless ($op eq $plus || $op eq $minus);
1.100 +
1.101 + my $cnt = shift(@fields);
1.102 +
1.103 + # Collect the remaining lines to create a stack trace.
1.104 + my @stack;
1.105 + CALLSITE: while (<$INFILE>) {
1.106 + chomp;
1.107 + last CALLSITE if (/^$/);
1.108 + $stack[++$#stack] = $_;
1.109 + }
1.110 +
1.111 + # Reverse the remaining fields to produce the call stack, with the
1.112 + # oldest frame at the front of the array.
1.113 + if (! $::opt_reverse) {
1.114 + @stack = reverse(@stack);
1.115 + }
1.116 +
1.117 + my $call;
1.118 +
1.119 + # If any of the functions in the stack are supposed to be excluded,
1.120 + # march on to the next line.
1.121 + foreach $call (@stack) {
1.122 + next LINE if exists($excludes{$call});
1.123 + }
1.124 +
1.125 +
1.126 + # Add the callstack as a path through the call graph, updating
1.127 + # refcounts at each node.
1.128 +
1.129 + my $caller = $callGraphRoot;
1.130 +
1.131 + foreach $call (@stack) {
1.132 +
1.133 + # Chop the method offset if we're 'collapsing to method' or
1.134 + # 'collapsing to class'.
1.135 + $call =~ s/\+0x.*$//g if ($::opt_collapse_to_method || $::opt_collapse_to_class);
1.136 +
1.137 + # Chop the method name if we're 'collapsing to class'.
1.138 + $call =~ s/::.*$//g if ($::opt_collapse_to_class);
1.139 +
1.140 + my $site = $caller->{$call};
1.141 + if (!$site) {
1.142 + # This is the first time we've seen this callsite. Add a
1.143 + # new entry to the call tree.
1.144 +
1.145 + $site = { '#name#' => $call, '#refcount#' => 0 };
1.146 + $caller->{$call} = $site;
1.147 + }
1.148 +
1.149 + if ($op eq $plus) {
1.150 + ++($site->{'#refcount#'});
1.151 + ++($imbalance{$call});
1.152 + } elsif ($op eq $minus) {
1.153 + --($site->{'#refcount#'});
1.154 + --($imbalance{$call});
1.155 + } else {
1.156 + die "Bad operation $op";
1.157 + }
1.158 +
1.159 + $caller = $site;
1.160 + }
1.161 + }
1.162 +}
1.163 +
1.164 +read_data(*STDIN, "AddRef", "Release");
1.165 +
1.166 +if ($::opt_comptrs) {
1.167 + warn "Subtracting comptr log ". $::opt_comptrs . "\n";
1.168 + open(COMPTRS, "<".$::opt_comptrs)
1.169 + || die "unable to open $::opt_comptrs";
1.170 +
1.171 + # read backwards to subtract
1.172 + read_data(*COMPTRS, "nsCOMPtrRelease", "nsCOMPtrAddRef");
1.173 +}
1.174 +
1.175 +sub num_alpha {
1.176 + my ($aN, $aS, $bN, $bS);
1.177 + ($aN, $aS) = ($1, $2) if $a =~ /^(\d+) (.+)$/;
1.178 + ($bN, $bS) = ($1, $2) if $b =~ /^(\d+) (.+)$/;
1.179 + return $a cmp $b unless defined $aN && defined $bN;
1.180 + return $aN <=> $bN unless $aN == $bN;
1.181 + return $aS cmp $bS;
1.182 +}
1.183 +
1.184 +# Given a subtree and its nesting level, return true if that subtree should be pruned.
1.185 +# If it shouldn't be pruned, destructively attempt to prune its children.
1.186 +# Also compute the #children# properties of unpruned nodes.
1.187 +sub prune($$) {
1.188 + my ($site, $nest) = @_;
1.189 +
1.190 + # If they want us to prune the tree's depth, do so here.
1.191 + return 1 if ($::opt_prune_depth && $nest >= $::opt_prune_depth);
1.192 +
1.193 + # If the subtree is balanced, ignore it.
1.194 + return 1 if ($::opt_ignore_balanced && !$site->{'#refcount#'});
1.195 +
1.196 + my $name = $site->{'#name#'};
1.197 +
1.198 + # If the symbol isn't imbalanced, then prune here (and warn)
1.199 + if ($::opt_ignore_balanced && !$imbalance{$name}) {
1.200 + warn "discarding " . $name . "\n";
1.201 +# return 1;
1.202 + }
1.203 +
1.204 + my @children;
1.205 + foreach my $child (sort num_alpha keys(%$site)) {
1.206 + if (substr($child, 0, 1) ne '#') {
1.207 + if (prune($site->{$child}, $nest + 1)) {
1.208 + delete $site->{$child};
1.209 + } else {
1.210 + push @children, $site->{$child};
1.211 + }
1.212 + }
1.213 + }
1.214 + $site->{'#children#'} = \@children;
1.215 + return 0;
1.216 +}
1.217 +
1.218 +
1.219 +# Compute the #label# properties of this subtree.
1.220 +# Return the subtree's number of nodes, not counting nodes reachable
1.221 +# through a labeled node.
1.222 +sub createLabels($) {
1.223 + my ($site) = @_;
1.224 + my @children = @{$site->{'#children#'}};
1.225 + my $nChildren = @children;
1.226 + my $nDescendants = 0;
1.227 +
1.228 + foreach my $child (@children) {
1.229 + my $childDescendants = createLabels($child);
1.230 + if ($nChildren > 1 && $childDescendants > $::opt_subtree_size) {
1.231 + die "Internal error" if defined($child->{'#label#'});
1.232 + $child->{'#label#'} = "__label__";
1.233 + $childDescendants = 1;
1.234 + }
1.235 + $nDescendants += $childDescendants;
1.236 + }
1.237 + return $nDescendants + 1;
1.238 +}
1.239 +
1.240 +
1.241 +my $nextLabel = 0;
1.242 +my @labeledSubtrees;
1.243 +
1.244 +sub list($$$$$) {
1.245 + my ($site, $nest, $nestStr, $childrenLeft, $root) = @_;
1.246 + my $label = !$root && $site->{'#label#'};
1.247 +
1.248 + # Assign a unique number to the label.
1.249 + if ($label) {
1.250 + die unless $label eq "__label__";
1.251 + $label = "__" . ++$nextLabel . "__";
1.252 + $site->{'#label#'} = $label;
1.253 + push @labeledSubtrees, $site;
1.254 + }
1.255 +
1.256 + print $nestStr;
1.257 + if ($::opt_old_style) {
1.258 + print $label, " " if $label;
1.259 + print $site->{'#name#'}, ": bal=", $site->{'#refcount#'}, "\n";
1.260 + } else {
1.261 + my $refcount = $site->{'#refcount#'};
1.262 + my $l = 8 - length $refcount;
1.263 + $l = 1 if $l < 1;
1.264 + print $refcount, " " x $l;
1.265 + print $label, " " if $label;
1.266 + print $site->{'#name#'}, "\n";
1.267 + }
1.268 +
1.269 + $nestStr .= $childrenLeft && !$::opt_old_style ? "| " : " ";
1.270 + if (!$label) {
1.271 + my @children = @{$site->{'#children#'}};
1.272 + $childrenLeft = @children;
1.273 + foreach my $child (@children) {
1.274 + $childrenLeft--;
1.275 + list($child, $nest + 1, $nestStr, $childrenLeft);
1.276 + }
1.277 + }
1.278 +}
1.279 +
1.280 +
1.281 +if (!prune($callGraphRoot, 0)) {
1.282 + createLabels $callGraphRoot if ($::opt_subtree_size);
1.283 + list $callGraphRoot, 0, "", 0, 1;
1.284 + while (@labeledSubtrees) {
1.285 + my $labeledSubtree = shift @labeledSubtrees;
1.286 + print "\n------------------------------\n",
1.287 +$labeledSubtree->{'#label#'}, "\n";
1.288 + list $labeledSubtree, 0, "", 0, 1;
1.289 + }
1.290 + print "\n------------------------------\n" if @labeledSubtrees;
1.291 +}
1.292 +
1.293 +print qq{
1.294 +Imbalance
1.295 +---------
1.296 +};
1.297 +
1.298 +foreach my $call (sort num_alpha keys(%imbalance)) {
1.299 + print $call . " " . $imbalance{$call} . "\n";
1.300 +}
1.301 +
