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. 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.
106 CALLSITE
: while (<$INFILE>) {
108 last CALLSITE
if (/^$/);
109 $_ =~ s/#\d+: /#00: /; # replace frame number with 0
110 $stack[++$#stack] = $_;
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);
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});
128 # Add the callstack as a path through the call graph, updating
129 # refcounts at each node.
131 my $caller = $callGraphRoot;
133 foreach $call (@stack) {
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
);
139 # Chop the method name if we're 'collapsing to class'.
140 $call =~ s/::.*$//g if ($::opt_collapse_to_class
);
142 my $site = $caller->{$call};
144 # This is the first time we've seen this callsite. Add a
145 # new entry to the call tree.
147 $site = { '#name#' => $call, '#refcount#' => 0 };
148 $caller->{$call} = $site;
152 ++($site->{'#refcount#'});
153 ++($imbalance{$call});
154 } elsif ($op eq $minus) {
155 --($site->{'#refcount#'});
156 --($imbalance{$call});
158 die "Bad operation $op";
166 read_data
(*STDIN
, "AddRef", "Release");
168 if ($::opt_comptrs
) {
169 warn "Subtracting comptr log ". $::opt_comptrs
. "\n";
170 open(COMPTRS
, "<".$::opt_comptrs
)
171 || die "unable to open $::opt_comptrs";
173 # read backwards to subtract
174 read_data
(*COMPTRS
, "nsCOMPtrRelease", "nsCOMPtrAddRef");
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;
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.
190 my ($site, $nest) = @_;
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
);
195 # If the subtree is balanced, ignore it.
196 return 1 if ($::opt_ignore_balanced
&& !$site->{'#refcount#'});
198 my $name = $site->{'#name#'};
200 # If the symbol isn't imbalanced, then prune here (and warn)
201 if ($::opt_ignore_balanced
&& !$imbalance{$name}) {
202 warn "discarding " . $name . "\n";
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};
212 push @children, $site->{$child};
216 $site->{'#children#'} = \
@children;
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
($) {
226 my @children = @
{$site->{'#children#'}};
227 my $nChildren = @children;
228 my $nDescendants = 0;
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;
237 $nDescendants += $childDescendants;
239 return $nDescendants + 1;
247 my ($site, $nest, $nestStr, $childrenLeft, $root) = @_;
248 my $label = !$root && $site->{'#label#'};
250 # Assign a unique number to the label.
252 die unless $label eq "__label__";
253 $label = "__" . ++$nextLabel . "__";
254 $site->{'#label#'} = $label;
255 push @labeledSubtrees, $site;
259 if ($::opt_old_style
) {
260 print $label, " " if $label;
261 print $site->{'#name#'}, ": bal=", $site->{'#refcount#'}, "\n";
263 my $refcount = $site->{'#refcount#'};
264 my $l = 8 - length $refcount;
266 print $refcount, " " x
$l;
267 print $label, " " if $label;
268 print $site->{'#name#'}, "\n";
271 $nestStr .= $childrenLeft && !$::opt_old_style ?
"| " : " ";
273 my @children = @
{$site->{'#children#'}};
274 $childrenLeft = @children;
275 foreach my $child (@children) {
277 list
($child, $nest + 1, $nestStr, $childrenLeft);
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;
292 print "\n------------------------------\n" if @labeledSubtrees;
300 foreach my $call (sort num_alpha
keys(%imbalance)) {
301 print $call . " " . $imbalance{$call} . "\n";