tools/trace-malloc/blame.pl

   1 #!/usr/bin/perl -w
   2 #
   3 # ***** BEGIN LICENSE BLOCK *****
   4 # Version: MPL 1.1/GPL 2.0/LGPL 2.1
   5 #
   6 # The contents of this file are subject to the Mozilla Public License Version
   7 # 1.1 (the "License"); you may not use this file except in compliance with
   8 # the License. You may obtain a copy of the License at
   9 # http://www.mozilla.org/MPL/
  10 #
  11 # Software distributed under the License is distributed on an "AS IS" basis,
  12 # WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
  13 # for the specific language governing rights and limitations under the
  14 # License.
  15 #
  16 # The Original Code is blame.pl, released
  17 # August 29, 2000.
  18 #
  19 # The Initial Developer of the Original Code is
  20 # Netscape Communications Corporation.
  21 # Portions created by the Initial Developer are Copyright (C) 2000
  22 # the Initial Developer. All Rights Reserved.
  23 #
  24 # Contributor(s):
  25 #   Chris Waterson <waterson@netscape.com>
  26 #
  27 # Alternatively, the contents of this file may be used under the terms of
  28 # either the GNU General Public License Version 2 or later (the "GPL"), or
  29 # the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
  30 # in which case the provisions of the GPL or the LGPL are applicable instead
  31 # of those above. If you wish to allow use of your version of this file only
  32 # under the terms of either the GPL or the LGPL, and not to allow others to
  33 # use your version of this file under the terms of the MPL, indicate your
  34 # decision by deleting the provisions above and replace them with the notice
  35 # and other provisions required by the GPL or the LGPL. If you do not delete
  36 # the provisions above, a recipient may use your version of this file under
  37 # the terms of any one of the MPL, the GPL or the LGPL.
  38 #
  39 # ***** END LICENSE BLOCK *****
  40
  41 #
  42 # Process output of TraceMallocDumpAllocations() to produce a table
  43 # that attributes memory to the allocators using call stack.
  44 #
  45
  46 use 5.004;
  47 use strict;
  48
  49 # A table of all ancestors. Key is function name, value is an
  50 # array of ancestors, each attributed with a number of calls and
  51 # the amount of memory allocated.
  52 my %Ancestors;
  53
  54 # Ibid, for descendants.
  55 my %Descendants;
  56
  57 # A table that keeps the total amount of memory allocated by each
  58 # function
  59 my %Totals;
  60 $Totals{".root"} = { "#memory#" => 0, "#calls#" => 0 };
  61
  62 # A table that maps the long ugly function name to a unique number so
  63 # that the HTML we generate isn't too fat
  64 my %Ids;
  65 my $NextId = 0;
  66
  67 $Ids{".root"} = ++$NextId;
  68
  69
  70 LINE: while (<>) {
  71     # The line'll look like:
  72     #
  73     #  0x4000a008     16  PR_Malloc+16; nsMemoryImpl::Alloc(unsigned int)+12; ...
  74
  75     # Ignore any lines that don't start with an address
  76     next LINE unless /^0x/;
  77
  78     # Parse it
  79     my ($address, $size, $rest) = /^(0x\S*)\s*(\d+)\s*(.*)$/;
  80     my @stack = reverse(split /; /, $rest);
  81
  82     # Accumulate at the root
  83     $Totals{".root"}->{"#memory#"} += $size;
  84     ++$Totals{".root"}->{"#calls#"};
  85
  86     my $caller = ".root";
  87     foreach my $callee (@stack) {
  88         # Strip the offset from the callsite information. I don't
  89         # think we care.
  90         $callee =~ s/\+\d+$//g;
  91
  92         # Accumulate the total for the callee
  93         if (! $Totals{$callee}) {
  94             $Totals{$callee} = { "#memory#" => 0, "#calls#" => 0 };
  95         }
  96
  97         $Totals{$callee}->{"#memory#"} += $size;
  98         ++$Totals{$callee}->{"#calls#"};
  99
 100         # Descendants
 101         my $descendants = $Descendants{$caller};
 102         if (! $descendants) {
 103             $descendants = $Descendants{$caller} = [ ];
 104         }
 105
 106         # Manage the list of descendants
 107         {
 108             my $wasInserted = 0;
 109           DESCENDANT: foreach my $item (@$descendants) {
 110                 if ($item->{"#name#"} eq $callee) {
 111                     $item->{"#memory#"} += $size;
 112                     ++$item->{"#calls#"};
 113                     $wasInserted = 1;
 114                     last DESCENDANT;
 115                 }
 116             }
 117
 118             if (! $wasInserted) {
 119                 $descendants->[@$descendants] = {
 120                     "#name#"   => $callee,
 121                     "#memory#" => $size,
 122                     "#calls#"  => 1
 123                 };
 124             }
 125         }
 126
 127         # Ancestors
 128         my $ancestors = $Ancestors{$callee};
 129         if (! $ancestors) {
 130             $ancestors = $Ancestors{$callee} = [ ];
 131         }
 132
 133         # Manage the list of ancestors
 134         {
 135             my $wasInserted = 0;
 136           ANCESTOR: foreach my $item (@$ancestors) {
 137                 if ($item->{"#name#"} eq $caller) {
 138                     $item->{"#memory#"} += $size;
 139                     ++$item->{"#calls#"};
 140                     $wasInserted = 1;
 141                     last ANCESTOR;
 142                 }
 143             }
 144
 145             if (! $wasInserted) {
 146                 $ancestors->[@$ancestors] = {
 147                     "#name#"   => $caller,
 148                     "#memory#" => $size,
 149                     "#calls#"  => 1
 150                 };
 151             }
 152         }
 153
 154         # Make a new "id", if necessary
 155         if (! $Ids{$callee}) {
 156             $Ids{$callee} = ++$NextId;
 157         }
 158
 159         # On to the next one...
 160         $caller = $callee;
 161     }
 162 }
 163
 164
 165 # Change the manky looking callsite into a pretty function; strip argument
 166 # types and offset information.
 167 sub pretty($) {
 168     $_ = $_[0];
 169     s/&/&amp;/g;
 170     s/</&lt;/g;
 171     s/>/&gt;/g;
 172
 173     if (/([^\(]*)(\(.*\))/) {
 174         return $1 . "()";
 175     }
 176     else {
 177         return $_[0];
 178     }
 179 }
 180
 181 # Dump a web page!
 182 print "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0//EN\">\n";
 183 print "<html><head>\n";
 184 print "<title>Live Bloat Blame</title>\n";
 185 print "<link rel=\"stylesheet\" type=\"text/css\" href=\"blame.css\">\n";
 186 print "</head>\n";
 187 print "<body>\n";
 188
 189 # At most 100 rows per table so as not to kill the browser.
 190 my $maxrows = 100;
 191
 192 print "<table>\n";
 193 print "<thead><tr><td>Function</td><td>Ancestors</td><td>Descendants</td></tr></thead>\n";
 194
 195 foreach my $node (sort(keys(%Ids))) {
 196     print "<tr>\n";
 197
 198     # Print the current node
 199     {
 200         my ($memory, $calls) =
 201             ($Totals{$node}->{"#memory#"},
 202              $Totals{$node}->{"#calls#"});
 203
 204         my $pretty = pretty($node);
 205         print "  <td><a name=\"$Ids{$node}\">$pretty&nbsp;$memory&nbsp;($calls)</a></td>\n";
 206     }
 207
 208     # Ancestors, sorted descending by amount of memory allocated
 209     print "  <td>\n";
 210     my $ancestors = $Ancestors{$node};
 211     if ($ancestors) {
 212         foreach my $ancestor (sort { $b->{"#memory#"} <=> $a->{"#memory#"} } @$ancestors) {
 213             my ($name, $memory, $calls) =
 214                 ($ancestor->{"#name#"},
 215                  $ancestor->{"#memory#"},
 216                  $ancestor->{"#calls#"});
 217
 218             my $pretty = pretty($name);
 219
 220             print "    <a href=\"#$Ids{$name}\">$pretty</a>&nbsp;$memory&nbsp;($calls)<br>\n";
 221         }
 222     }
 223
 224     print "  </td>\n";
 225
 226     # Descendants, sorted descending by amount of memory allocated
 227     print "  <td>\n";
 228     my $descendants = $Descendants{$node};
 229     if ($descendants) {
 230         foreach my $descendant (sort { $b->{"#memory#"} <=> $a->{"#memory#"} } @$descendants) {
 231             my ($name, $memory, $calls) =
 232                 ($descendant->{"#name#"},
 233                  $descendant->{"#memory#"},
 234                  $descendant->{"#calls#"});
 235
 236             my $pretty = pretty($name);
 237
 238             print "    <a href=\"#$Ids{$name}\">$pretty</a>&nbsp;$memory&nbsp;($calls)<br>\n";
 239         }
 240     }
 241     print "  </td></tr>\n";
 242
 243     if (--$maxrows == 0) {
 244         print "</table>\n";
 245         print "<table>\n";
 246         print "<thead><tr><td>Function</td><td>Ancestors</td><td>Descendants</td></tr></thead>\n";
 247         $maxrows = 100;
 248     }
 249 }
 250
 251 # Footer
 252 print "</table>\n";
 253 print "</body></html>\n";