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/.
11 $::opt_prune_depth
= 0;
12 $::opt_subtree_size
= 0;
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");
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
35 $::opt_prune_depth
= 0 if $::opt_prune_depth
< 0;
36 $::opt_subtree_size
= 0 if $::opt_subtree_size
< 0;
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
;
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.
54 open(EXCLUDE
, "<".$::opt_exclude
)
55 || die "unable to open $::opt_exclude";
59 warn "excluding $_\n";
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.
72 $callGraphRoot = { '#name#' => '.root', '#refcount#' => 'n/a' };
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.
79 $imbalance{'.root'} = 'n/a';
84 my ($INFILE, $plus, $minus) = @_;
86 LINE
: while (<$INFILE>) {
87 next LINE
if (! /^</);
88 my @fields = split(/ /, $_);
90 my $class = shift(@fields);
91 my $obj = shift(@fields);
92 my $sno = shift(@fields);
93 next LINE
unless ($obj eq $::opt_object
);
95 my $op = shift(@fields);
96 next LINE
unless ($op eq $plus || $op eq $minus);
98 my $cnt = shift(@fields);
100 # Collect the remaining lines to create a stack trace.
102 CALLSITE
: while (<$INFILE>) {
104 last CALLSITE
if (/^$/);
105 $stack[++$#stack] = $_;
108 # Reverse the remaining fields to produce the call stack, with the
109 # oldest frame at the front of the array.
110 if (! $::opt_reverse
) {
111 @stack = reverse(@stack);
116 # If any of the functions in the stack are supposed to be excluded,
117 # march on to the next line.
118 foreach $call (@stack) {
119 next LINE
if exists($excludes{$call});
123 # Add the callstack as a path through the call graph, updating
124 # refcounts at each node.
126 my $caller = $callGraphRoot;
128 foreach $call (@stack) {
130 # Chop the method offset if we're 'collapsing to method' or
131 # 'collapsing to class'.
132 $call =~ s/\+0x.*$//g if ($::opt_collapse_to_method
|| $::opt_collapse_to_class
);
134 # Chop the method name if we're 'collapsing to class'.
135 $call =~ s/::.*$//g if ($::opt_collapse_to_class
);
137 my $site = $caller->{$call};
139 # This is the first time we've seen this callsite. Add a
140 # new entry to the call tree.
142 $site = { '#name#' => $call, '#refcount#' => 0 };
143 $caller->{$call} = $site;
147 ++($site->{'#refcount#'});
148 ++($imbalance{$call});
149 } elsif ($op eq $minus) {
150 --($site->{'#refcount#'});
151 --($imbalance{$call});
153 die "Bad operation $op";
161 read_data
(*STDIN
, "AddRef", "Release");
163 if ($::opt_comptrs
) {
164 warn "Subtracting comptr log ". $::opt_comptrs
. "\n";
165 open(COMPTRS
, "<".$::opt_comptrs
)
166 || die "unable to open $::opt_comptrs";
168 # read backwards to subtract
169 read_data
(*COMPTRS
, "nsCOMPtrRelease", "nsCOMPtrAddRef");
173 my ($aN, $aS, $bN, $bS);
174 ($aN, $aS) = ($1, $2) if $a =~ /^(\d+) (.+)$/;
175 ($bN, $bS) = ($1, $2) if $b =~ /^(\d+) (.+)$/;
176 return $a cmp $b unless defined $aN && defined $bN;
177 return $aN <=> $bN unless $aN == $bN;
181 # Given a subtree and its nesting level, return true if that subtree should be pruned.
182 # If it shouldn't be pruned, destructively attempt to prune its children.
183 # Also compute the #children# properties of unpruned nodes.
185 my ($site, $nest) = @_;
187 # If they want us to prune the tree's depth, do so here.
188 return 1 if ($::opt_prune_depth
&& $nest >= $::opt_prune_depth
);
190 # If the subtree is balanced, ignore it.
191 return 1 if ($::opt_ignore_balanced
&& !$site->{'#refcount#'});
193 my $name = $site->{'#name#'};
195 # If the symbol isn't imbalanced, then prune here (and warn)
196 if ($::opt_ignore_balanced
&& !$imbalance{$name}) {
197 warn "discarding " . $name . "\n";
202 foreach my $child (sort num_alpha
keys(%$site)) {
203 if (substr($child, 0, 1) ne '#') {
204 if (prune
($site->{$child}, $nest + 1)) {
205 delete $site->{$child};
207 push @children, $site->{$child};
211 $site->{'#children#'} = \
@children;
216 # Compute the #label# properties of this subtree.
217 # Return the subtree's number of nodes, not counting nodes reachable
218 # through a labeled node.
219 sub createLabels
($) {
221 my @children = @
{$site->{'#children#'}};
222 my $nChildren = @children;
223 my $nDescendants = 0;
225 foreach my $child (@children) {
226 my $childDescendants = createLabels
($child);
227 if ($nChildren > 1 && $childDescendants > $::opt_subtree_size
) {
228 die "Internal error" if defined($child->{'#label#'});
229 $child->{'#label#'} = "__label__";
230 $childDescendants = 1;
232 $nDescendants += $childDescendants;
234 return $nDescendants + 1;
242 my ($site, $nest, $nestStr, $childrenLeft, $root) = @_;
243 my $label = !$root && $site->{'#label#'};
245 # Assign a unique number to the label.
247 die unless $label eq "__label__";
248 $label = "__" . ++$nextLabel . "__";
249 $site->{'#label#'} = $label;
250 push @labeledSubtrees, $site;
254 if ($::opt_old_style
) {
255 print $label, " " if $label;
256 print $site->{'#name#'}, ": bal=", $site->{'#refcount#'}, "\n";
258 my $refcount = $site->{'#refcount#'};
259 my $l = 8 - length $refcount;
261 print $refcount, " " x
$l;
262 print $label, " " if $label;
263 print $site->{'#name#'}, "\n";
266 $nestStr .= $childrenLeft && !$::opt_old_style ?
"| " : " ";
268 my @children = @
{$site->{'#children#'}};
269 $childrenLeft = @children;
270 foreach my $child (@children) {
272 list
($child, $nest + 1, $nestStr, $childrenLeft);
278 if (!prune
($callGraphRoot, 0)) {
279 createLabels
$callGraphRoot if ($::opt_subtree_size
);
280 list
$callGraphRoot, 0, "", 0, 1;
281 while (@labeledSubtrees) {
282 my $labeledSubtree = shift @labeledSubtrees;
283 print "\n------------------------------\n",
284 $labeledSubtree->{'#label#'}, "\n";
285 list
$labeledSubtree, 0, "", 0, 1;
287 print "\n------------------------------\n" if @labeledSubtrees;
295 foreach my $call (sort num_alpha
keys(%imbalance)) {
296 print $call . " " . $imbalance{$call} . "\n";