Adding upstream version 110.0.1.upstream/110.0.1upstream

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

1 files changed, 303 insertions, 0 deletions

diff --git a/tools/rb/make-tree.pl b/tools/rb/make-tree.pl
new file mode 100755
index 0000000000..04f0d85341
--- /dev/null
+++ b/tools/rb/make-tree.pl
@@ -0,0 +1,303 @@
+#!/usr/bin/perl -w
+#
+# This Source Code Form is subject to the terms of the Mozilla Public
+# License, v. 2.0. If a copy of the MPL was not distributed with this
+# file, You can obtain one at http://mozilla.org/MPL/2.0/.
+
+use 5.004;
+use strict;
+use Getopt::Long;
+
+$::opt_prune_depth = 0;
+$::opt_subtree_size = 0;
+$::opt_reverse = 0;
+
+# GetOption will create $opt_object & $opt_exclude, so ignore the
+# warning that gets spit out about those vbls.
+GetOptions("object=s", "exclude=s", "comptrs=s", "ignore-balanced", "subtree-size=i", "prune-depth=i",
+            "collapse-to-method", "collapse-to-class", "old-style", "reverse");
+
+$::opt_object ||
+     die qq{
+usage: leak.pl < logfile
+  --object <obj>         The address of the object to examine (required)
+  --exclude <file>       Exclude routines listed in <file>
+  --comptrs <file>       Subtract all the data in the balanced COMPtr log <file>
+  --ignore-balanced      Ignore balanced subtrees
+  --subtree-size <n>     Print subtrees with more than <n> nodes separately
+  --prune-depth <depth>  Prune the tree to <depth>
+  --collapse-to-method   Aggregate data by method
+  --collapse-to-class    Aggregate data by class (subsumes --collapse-to-method)
+  --reverse              Reverse call stacks, showing leaves first
+  --old-style            Old-style formatting
+};
+
+$::opt_prune_depth = 0 if $::opt_prune_depth < 0;
+$::opt_subtree_size = 0 if $::opt_subtree_size < 0;
+
+warn "object $::opt_object\n";
+warn "ignoring balanced subtrees\n" if $::opt_ignore_balanced;
+warn "prune depth $::opt_prune_depth\n" if $::opt_prune_depth;
+warn "collapsing to class\n" if $::opt_collapse_to_class;
+warn "collapsing to method\n" if $::opt_collapse_to_method && !$::opt_collapse_to_class;
+warn "reversing call stacks\n" if $::opt_reverse;
+
+
+# The 'excludes' are functions that, if detected in a particular call
+# stack, will cause the _entire_ call stack to be ignored. You might,
+# for example, explicitly exclude two functions that have a matching
+# AddRef/Release pair.
+
+my %excludes;
+
+if ($::opt_exclude) {
+     open(EXCLUDE, "<".$::opt_exclude)
+         || die "unable to open $::opt_exclude";
+ 
+     while (<EXCLUDE>) {
+         chomp $_;
+         warn "excluding $_\n";
+         $excludes{$_} = 1;
+     }
+}
+
+# Each entry in the tree rooted by callGraphRoot contains the following:
+#   #name#      This call's name+offset string
+#   #refcount#  The net reference count of this call
+#   #label#     The label used for this subtree; only defined for labeled nodes
+#   #children#  List of children in alphabetical order
+# zero or more children indexed by method name+offset strings.
+
+my $callGraphRoot;
+$callGraphRoot = { '#name#' => '.root', '#refcount#' => 'n/a' };
+
+# The 'imbalance' is a gross count of how balanced a particular
+# callsite is. It is used to prune away callsites that are detected to
+# be balanced; that is, that have matching AddRef/Release() pairs.
+
+my %imbalance;
+$imbalance{'.root'} = 'n/a';
+
+# The main read loop.
+
+sub read_data($$$) {
+     my ($INFILE, $plus, $minus) = @_;
+
+     LINE: while (<$INFILE>) {
+          next LINE if (! /^</);
+          my @fields = split(/ /, $_);
+     
+          my $class = shift(@fields);
+          my $obj   = shift(@fields);
+          my $sno   = shift(@fields);
+          next LINE unless ($obj eq $::opt_object);
+     
+          my $op  = shift(@fields);
+          next LINE unless ($op eq $plus || $op eq $minus);
+     
+          my $cnt = shift(@fields);
+     
+          # Collect the remaining lines to create a stack trace. We need to
+          # filter out the frame numbers so that frames that differ only in
+          # their frame number are considered equivalent. However, we need to
+          # keep a frame number on each line so that the fix*.py scripts can
+          # parse the output. So we set the frame number to 0 for every frame.
+          my @stack;
+          CALLSITE: while (<$INFILE>) {
+              chomp;
+              last CALLSITE if (/^$/);
+              $_ =~ s/#\d+: /#00: /;    # replace frame number with 0
+              $stack[++$#stack] = $_;
+          }
+     
+          # Reverse the remaining fields to produce the call stack, with the
+          # oldest frame at the front of the array.
+          if (! $::opt_reverse) {
+              @stack = reverse(@stack);
+          }
+     
+          my $call;
+     
+          # If any of the functions in the stack are supposed to be excluded,
+          # march on to the next line.
+          foreach $call (@stack) {
+              next LINE if exists($excludes{$call});
+          }
+     
+     
+          # Add the callstack as a path through the call graph, updating
+          # refcounts at each node.
+     
+          my $caller = $callGraphRoot;
+     
+          foreach $call (@stack) {
+     
+              # Chop the method offset if we're 'collapsing to method' or
+              # 'collapsing to class'.
+              $call =~ s/\+0x.*$//g if ($::opt_collapse_to_method || $::opt_collapse_to_class);
+     
+              # Chop the method name if we're 'collapsing to class'.
+              $call =~ s/::.*$//g if ($::opt_collapse_to_class);
+     
+              my $site = $caller->{$call};
+              if (!$site) {
+                  # This is the first time we've seen this callsite. Add a
+                  # new entry to the call tree.
+     
+                  $site = { '#name#' => $call, '#refcount#' => 0 };
+                  $caller->{$call} = $site;
+              }
+     
+              if ($op eq $plus) {
+                  ++($site->{'#refcount#'});
+                  ++($imbalance{$call});
+              } elsif ($op eq $minus) {
+                  --($site->{'#refcount#'});
+                  --($imbalance{$call});
+              } else {
+                  die "Bad operation $op";
+              }
+     
+              $caller = $site;
+          }
+     }
+}
+
+read_data(*STDIN, "AddRef", "Release");
+
+if ($::opt_comptrs) {
+     warn "Subtracting comptr log ". $::opt_comptrs . "\n";
+     open(COMPTRS, "<".$::opt_comptrs)
+         || die "unable to open $::opt_comptrs";
+
+     # read backwards to subtract
+     read_data(*COMPTRS, "nsCOMPtrRelease", "nsCOMPtrAddRef");
+}
+
+sub num_alpha {
+     my ($aN, $aS, $bN, $bS);
+     ($aN, $aS) = ($1, $2) if $a =~ /^(\d+) (.+)$/;
+     ($bN, $bS) = ($1, $2) if $b =~ /^(\d+) (.+)$/;
+     return $a cmp $b unless defined $aN && defined $bN;
+     return $aN <=> $bN unless $aN == $bN;
+     return $aS cmp $bS;
+}
+
+# Given a subtree and its nesting level, return true if that subtree should be pruned.
+# If it shouldn't be pruned, destructively attempt to prune its children.
+# Also compute the #children# properties of unpruned nodes.
+sub prune($$) {
+     my ($site, $nest) = @_;
+
+     # If they want us to prune the tree's depth, do so here.
+     return 1 if ($::opt_prune_depth && $nest >= $::opt_prune_depth);
+
+     # If the subtree is balanced, ignore it.
+     return 1 if ($::opt_ignore_balanced && !$site->{'#refcount#'});
+
+     my $name = $site->{'#name#'};
+
+     # If the symbol isn't imbalanced, then prune here (and warn)
+     if ($::opt_ignore_balanced && !$imbalance{$name}) {
+         warn "discarding " . $name . "\n";
+#         return 1;
+     }
+
+     my @children;
+     foreach my $child (sort num_alpha keys(%$site)) {
+         if (substr($child, 0, 1) ne '#') {
+             if (prune($site->{$child}, $nest + 1)) {
+                 delete $site->{$child};
+             } else {
+                 push @children, $site->{$child};
+             }
+         }
+     }
+     $site->{'#children#'} = \@children;
+     return 0;
+}
+
+
+# Compute the #label# properties of this subtree.
+# Return the subtree's number of nodes, not counting nodes reachable 
+# through a labeled node.
+sub createLabels($) {
+     my ($site) = @_;
+     my @children = @{$site->{'#children#'}};
+     my $nChildren = @children;
+     my $nDescendants = 0;
+
+     foreach my $child (@children) {
+         my $childDescendants = createLabels($child);
+         if ($nChildren > 1 && $childDescendants > $::opt_subtree_size) {
+             die "Internal error" if defined($child->{'#label#'});
+             $child->{'#label#'} = "__label__";
+             $childDescendants = 1;
+         }
+         $nDescendants += $childDescendants;
+     }
+     return $nDescendants + 1;
+}
+
+
+my $nextLabel = 0;
+my @labeledSubtrees;
+
+sub list($$$$$) {
+     my ($site, $nest, $nestStr, $childrenLeft, $root) = @_;
+     my $label = !$root && $site->{'#label#'};
+
+     # Assign a unique number to the label.
+     if ($label) {
+         die unless $label eq "__label__";
+         $label = "__" . ++$nextLabel . "__";
+         $site->{'#label#'} = $label;
+         push @labeledSubtrees, $site;
+     }
+
+     print $nestStr;
+     if ($::opt_old_style) {
+         print $label, " " if $label;
+         print $site->{'#name#'}, ": bal=", $site->{'#refcount#'}, "\n";
+     } else {
+         my $refcount = $site->{'#refcount#'};
+         my $l = 8 - length $refcount;
+         $l = 1 if $l < 1;
+         print $refcount, " " x $l;
+         print $label, " " if $label;
+         print $site->{'#name#'}, "\n";
+     }
+
+     $nestStr .= $childrenLeft && !$::opt_old_style ? "| " : "  ";
+     if (!$label) {
+         my @children = @{$site->{'#children#'}};
+         $childrenLeft = @children;
+         foreach my $child (@children) {
+             $childrenLeft--;
+             list($child, $nest + 1, $nestStr, $childrenLeft);
+         }
+     }
+}
+
+
+if (!prune($callGraphRoot, 0)) {
+     createLabels $callGraphRoot if ($::opt_subtree_size);
+     list $callGraphRoot, 0, "", 0, 1;
+     while (@labeledSubtrees) {
+         my $labeledSubtree = shift @labeledSubtrees;
+         print "\n------------------------------\n", 
+$labeledSubtree->{'#label#'}, "\n";
+         list $labeledSubtree, 0, "", 0, 1;
+     }
+     print "\n------------------------------\n" if @labeledSubtrees;
+}
+
+print qq{
+Imbalance
+---------
+};
+
+foreach my $call (sort num_alpha keys(%imbalance)) {
+     print $call . " " . $imbalance{$call} . "\n";
+}
+