The Tor Browser / file comparison
comparison: tools/rb/make-tree.pl
tools/rb/make-tree.pl
- branch
- TOR_BUG_9701
- changeset 8
- 97036ab72558
equal
deleted
inserted
replaced
| -1:000000000000 | 0:a52dc0c15142 |
|---|---|
| 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. | |
| 101 my @stack; | |
| 102 CALLSITE: while (<$INFILE>) { | |
| 103 chomp; | |
| 104 last CALLSITE if (/^$/); | |
| 105 $stack[++$#stack] = $_; | |
| 106 } | |
| 107 | |
| 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); | |
| 112 } | |
| 113 | |
| 114 my $call; | |
| 115 | |
| 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}); | |
| 120 } | |
| 121 | |
| 122 | |
| 123 # Add the callstack as a path through the call graph, updating | |
| 124 # refcounts at each node. | |
| 125 | |
| 126 my $caller = $callGraphRoot; | |
| 127 | |
| 128 foreach $call (@stack) { | |
| 129 | |
| 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); | |
| 133 | |
| 134 # Chop the method name if we're 'collapsing to class'. | |
| 135 $call =~ s/::.*$//g if ($::opt_collapse_to_class); | |
| 136 | |
| 137 my $site = $caller->{$call}; | |
| 138 if (!$site) { | |
| 139 # This is the first time we've seen this callsite. Add a | |
| 140 # new entry to the call tree. | |
| 141 | |
| 142 $site = { '#name#' => $call, '#refcount#' => 0 }; | |
| 143 $caller->{$call} = $site; | |
| 144 } | |
| 145 | |
| 146 if ($op eq $plus) { | |
| 147 ++($site->{'#refcount#'}); | |
| 148 ++($imbalance{$call}); | |
| 149 } elsif ($op eq $minus) { | |
| 150 --($site->{'#refcount#'}); | |
| 151 --($imbalance{$call}); | |
| 152 } else { | |
| 153 die "Bad operation $op"; | |
| 154 } | |
| 155 | |
| 156 $caller = $site; | |
| 157 } | |
| 158 } | |
| 159 } | |
| 160 | |
| 161 read_data(*STDIN, "AddRef", "Release"); | |
| 162 | |
| 163 if ($::opt_comptrs) { | |
| 164 warn "Subtracting comptr log ". $::opt_comptrs . "\n"; | |
| 165 open(COMPTRS, "<".$::opt_comptrs) | |
| 166 || die "unable to open $::opt_comptrs"; | |
| 167 | |
| 168 # read backwards to subtract | |
| 169 read_data(*COMPTRS, "nsCOMPtrRelease", "nsCOMPtrAddRef"); | |
| 170 } | |
| 171 | |
| 172 sub num_alpha { | |
| 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; | |
| 178 return $aS cmp $bS; | |
| 179 } | |
| 180 | |
| 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. | |
| 184 sub prune($$) { | |
| 185 my ($site, $nest) = @_; | |
| 186 | |
| 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); | |
| 189 | |
| 190 # If the subtree is balanced, ignore it. | |
| 191 return 1 if ($::opt_ignore_balanced && !$site->{'#refcount#'}); | |
| 192 | |
| 193 my $name = $site->{'#name#'}; | |
| 194 | |
| 195 # If the symbol isn't imbalanced, then prune here (and warn) | |
| 196 if ($::opt_ignore_balanced && !$imbalance{$name}) { | |
| 197 warn "discarding " . $name . "\n"; | |
| 198 # return 1; | |
| 199 } | |
| 200 | |
| 201 my @children; | |
| 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}; | |
| 206 } else { | |
| 207 push @children, $site->{$child}; | |
| 208 } | |
| 209 } | |
| 210 } | |
| 211 $site->{'#children#'} = \@children; | |
| 212 return 0; | |
| 213 } | |
| 214 | |
| 215 | |
| 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($) { | |
| 220 my ($site) = @_; | |
| 221 my @children = @{$site->{'#children#'}}; | |
| 222 my $nChildren = @children; | |
| 223 my $nDescendants = 0; | |
| 224 | |
| 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; | |
| 231 } | |
| 232 $nDescendants += $childDescendants; | |
| 233 } | |
| 234 return $nDescendants + 1; | |
| 235 } | |
| 236 | |
| 237 | |
| 238 my $nextLabel = 0; | |
| 239 my @labeledSubtrees; | |
| 240 | |
| 241 sub list($$$$$) { | |
| 242 my ($site, $nest, $nestStr, $childrenLeft, $root) = @_; | |
| 243 my $label = !$root && $site->{'#label#'}; | |
| 244 | |
| 245 # Assign a unique number to the label. | |
| 246 if ($label) { | |
| 247 die unless $label eq "__label__"; | |
| 248 $label = "__" . ++$nextLabel . "__"; | |
| 249 $site->{'#label#'} = $label; | |
| 250 push @labeledSubtrees, $site; | |
| 251 } | |
| 252 | |
| 253 print $nestStr; | |
| 254 if ($::opt_old_style) { | |
| 255 print $label, " " if $label; | |
| 256 print $site->{'#name#'}, ": bal=", $site->{'#refcount#'}, "\n"; | |
| 257 } else { | |
| 258 my $refcount = $site->{'#refcount#'}; | |
| 259 my $l = 8 - length $refcount; | |
| 260 $l = 1 if $l < 1; | |
| 261 print $refcount, " " x $l; | |
| 262 print $label, " " if $label; | |
| 263 print $site->{'#name#'}, "\n"; | |
| 264 } | |
| 265 | |
| 266 $nestStr .= $childrenLeft && !$::opt_old_style ? "| " : " "; | |
| 267 if (!$label) { | |
| 268 my @children = @{$site->{'#children#'}}; | |
| 269 $childrenLeft = @children; | |
| 270 foreach my $child (@children) { | |
| 271 $childrenLeft--; | |
| 272 list($child, $nest + 1, $nestStr, $childrenLeft); | |
| 273 } | |
| 274 } | |
| 275 } | |
| 276 | |
| 277 | |
| 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; | |
| 286 } | |
| 287 print "\n------------------------------\n" if @labeledSubtrees; | |
| 288 } | |
| 289 | |
| 290 print qq{ | |
| 291 Imbalance | |
| 292 --------- | |
| 293 }; | |
| 294 | |
| 295 foreach my $call (sort num_alpha keys(%imbalance)) { | |
| 296 print $call . " " . $imbalance{$call} . "\n"; | |
| 297 } | |
| 298 |
