tools/trace-malloc/TraceMalloc.pm

   1 # ***** BEGIN LICENSE BLOCK *****
   2 # Version: MPL 1.1/GPL 2.0/LGPL 2.1
   3 #
   4 # The contents of this file are subject to the Mozilla Public License Version
   5 # 1.1 (the "License"); you may not use this file except in compliance with
   6 # the License. You may obtain a copy of the License at
   7 # http://www.mozilla.org/MPL/
   8 #
   9 # Software distributed under the License is distributed on an "AS IS" basis,
  10 # WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
  11 # for the specific language governing rights and limitations under the
  12 # License.
  13 #
  14 # The Original Code is TraceMalloc.pm, released
  15 # Nov 27, 2000.
  16 #
  17 # The Initial Developer of the Original Code is
  18 # Netscape Communications Corporation.
  19 # Portions created by the Initial Developer are Copyright (C) 2000
  20 # the Initial Developer. All Rights Reserved.
  21 #
  22 # Contributor(s):
  23 #   Chris Waterson <waterson@netscape.com>
  24 #
  25 # Alternatively, the contents of this file may be used under the terms of
  26 # either the GNU General Public License Version 2 or later (the "GPL"), or
  27 # the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
  28 # in which case the provisions of the GPL or the LGPL are applicable instead
  29 # of those above. If you wish to allow use of your version of this file only
  30 # under the terms of either the GPL or the LGPL, and not to allow others to
  31 # use your version of this file under the terms of the MPL, indicate your
  32 # decision by deleting the provisions above and replace them with the notice
  33 # and other provisions required by the GPL or the LGPL. If you do not delete
  34 # the provisions above, a recipient may use your version of this file under
  35 # the terms of any one of the MPL, the GPL or the LGPL.
  36 #
  37 # ***** END LICENSE BLOCK *****
  38 package TraceMalloc;
  39
  40 use strict;
  41
  42 # Read in the type inference file and construct a network that we can
  43 # use to match stack prefixes to types.
  44 sub init_type_inference($) {
  45     my ($file) = @_;
  46
  47     $::Fingerprints = { };
  48
  49     open(TYPES, "<$file") || die "unable to open $::opt_types, $!";
  50
  51   TYPE: while (<TYPES>) {
  52       next TYPE unless /<(.*)>/;
  53       my $type = $1;
  54
  55       my $link = \%::Fingerprints;
  56
  57     FRAME: while (<TYPES>) {
  58         chomp;
  59         last FRAME if /^$/;
  60
  61         my $next = $link->{$_};
  62         if (! $next) {
  63             $next = $link->{$_} = {};
  64         }
  65         $link = $next;
  66     }
  67
  68       $link->{'#type#'} = $type;
  69
  70       last TYPE if eof;
  71   }
  72 }
  73
  74 # Infer the type, trying to find the most specific type possible.
  75 sub infer_type($) {
  76     my ($stack) = @_;
  77
  78     my $link = \%::Fingerprints;
  79     my $last;
  80     my $type = 'void*';
  81   FRAME: foreach my $frame (@$stack) {
  82       last FRAME unless $link;
  83
  84       $frame =~ s/\[.*\]$//; # ignore exact addresses, as they'll drift
  85
  86       $last = $link;
  87
  88       #
  89       # Remember this type, but keep going.  We use the longest match
  90       # we find, but substacks of longer matches will also match.
  91       #
  92       if ($last->{'#type#'}) {
  93           $type = $last->{'#type#'};
  94       }
  95
  96       $link = $link->{$frame};
  97
  98       if (! $link) {
  99         CHILD: foreach my $child (keys %$last) {
 100             next CHILD unless $child =~ /^~/;
 101
 102             $child =~ s/^~//;
 103
 104             if ($frame =~ $child) {
 105                 $link = $last->{'~' . $child};
 106                 last CHILD;
 107             }
 108           }
 109       }
 110   }
 111
 112     return $type;
 113 }
 114
 115 \f
 116 #----------------------------------------------------------------------
 117 #
 118 # Read in the output a trace malloc's dump.
 119 #
 120 sub read {
 121     my ($callback, $noslop) = @_;
 122
 123   OBJECT: while (<>) {
 124       # e.g., 0x0832FBD0 <void*> (80)
 125       next OBJECT unless /^0x(\S+) <(.*)> \((\d+)\)/;
 126       my ($addr, $type, $size) = (hex $1, $2, $3);
 127
 128       my $object = { 'type' => $type, 'size' => $size };
 129
 130       # Record the object's slots
 131       my @slots;
 132
 133     SLOT: while (<>) {
 134         # e.g.,      0x00000000
 135         last SLOT unless /^\t0x(\S+)/;
 136         my $value = hex $1;
 137
 138         # Ignore low bits, unless they've specified --noslop
 139         $value &= ~0x7 unless $noslop;
 140
 141         $slots[$#slots + 1] = $value;
 142     }
 143
 144       $object->{'slots'} = \@slots;
 145
 146       # Record the stack by which the object was allocated
 147       my @stack;
 148
 149       while (/^(.*)\[(.*) \+0x(\S+)\]$/) {
 150           # e.g., _dl_debug_message[/lib/ld-linux.so.2 +0x0000B858]
 151           my ($func, $lib, $off) = ($1, $2, hex $3);
 152
 153           chomp;
 154           $stack[$#stack + 1] = $_;
 155
 156           $_ = <>;
 157       }
 158
 159       $object->{'stack'} = \@stack;
 160
 161       $object->{'type'} = infer_type(\@stack)
 162           if $object->{'type'} eq 'void*';
 163
 164       &$callback($object) if $callback;
 165
 166       # Gotta check EOF explicitly...
 167       last OBJECT if eof;
 168   }
 169 }
 170
 171 1;
 172 __END__
 173
 174 =head1 NAME
 175
 176 TraceMalloc - Perl routines to deal with output from ``trace malloc''
 177 and the Boehm GC
 178
 179 =head1 SYNOPSIS
 180
 181     use TraceMalloc;
 182
 183     TraceMalloc::init_type_inference("types.dat");
 184     TraceMalloc::read(0);
 185
 186 =head1 DESCRIPTION
 187
 188 =head1 EXAMPLES
 189
 190 =cut