1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/tools/trace-malloc/TraceMalloc.pm Wed Dec 31 06:09:35 2014 +0100
1.3 @@ -0,0 +1,156 @@
1.4 +# This Source Code Form is subject to the terms of the Mozilla Public
1.5 +# License, v. 2.0. If a copy of the MPL was not distributed with this
1.6 +# file, You can obtain one at http://mozilla.org/MPL/2.0/.
1.7 +package TraceMalloc;
1.8 +
1.9 +use strict;
1.10 +
1.11 +# Read in the type inference file and construct a network that we can
1.12 +# use to match stack prefixes to types.
1.13 +sub init_type_inference($) {
1.14 + my ($file) = @_;
1.15 +
1.16 + $::Fingerprints = { };
1.17 +
1.18 + open(TYPES, "<$file") || die "unable to open $::opt_types, $!";
1.19 +
1.20 + TYPE: while (<TYPES>) {
1.21 + next TYPE unless /<(.*)>/;
1.22 + my $type = $1;
1.23 +
1.24 + my $link = \%::Fingerprints;
1.25 +
1.26 + FRAME: while (<TYPES>) {
1.27 + chomp;
1.28 + last FRAME if /^$/;
1.29 +
1.30 + my $next = $link->{$_};
1.31 + if (! $next) {
1.32 + $next = $link->{$_} = {};
1.33 + }
1.34 + $link = $next;
1.35 + }
1.36 +
1.37 + $link->{'#type#'} = $type;
1.38 +
1.39 + last TYPE if eof;
1.40 + }
1.41 +}
1.42 +
1.43 +# Infer the type, trying to find the most specific type possible.
1.44 +sub infer_type($) {
1.45 + my ($stack) = @_;
1.46 +
1.47 + my $link = \%::Fingerprints;
1.48 + my $last;
1.49 + my $type = 'void*';
1.50 + FRAME: foreach my $frame (@$stack) {
1.51 + last FRAME unless $link;
1.52 +
1.53 + $frame =~ s/\[.*\]$//; # ignore exact addresses, as they'll drift
1.54 +
1.55 + $last = $link;
1.56 +
1.57 + #
1.58 + # Remember this type, but keep going. We use the longest match
1.59 + # we find, but substacks of longer matches will also match.
1.60 + #
1.61 + if ($last->{'#type#'}) {
1.62 + $type = $last->{'#type#'};
1.63 + }
1.64 +
1.65 + $link = $link->{$frame};
1.66 +
1.67 + if (! $link) {
1.68 + CHILD: foreach my $child (keys %$last) {
1.69 + next CHILD unless $child =~ /^~/;
1.70 +
1.71 + $child =~ s/^~//;
1.72 +
1.73 + if ($frame =~ $child) {
1.74 + $link = $last->{'~' . $child};
1.75 + last CHILD;
1.76 + }
1.77 + }
1.78 + }
1.79 + }
1.80 +
1.81 + return $type;
1.82 +}
1.83 +
1.84 +
1.85 +#----------------------------------------------------------------------
1.86 +#
1.87 +# Read in the output a trace malloc's dump.
1.88 +#
1.89 +sub read {
1.90 + my ($callback, $noslop) = @_;
1.91 +
1.92 + OBJECT: while (<>) {
1.93 + # e.g., 0x0832FBD0 <void*> (80)
1.94 + next OBJECT unless /^0x(\S+) <(.*)> \((\d+)\)/;
1.95 + my ($addr, $type, $size) = (hex $1, $2, $3);
1.96 +
1.97 + my $object = { 'type' => $type, 'size' => $size };
1.98 +
1.99 + # Record the object's slots
1.100 + my @slots;
1.101 +
1.102 + SLOT: while (<>) {
1.103 + # e.g., 0x00000000
1.104 + last SLOT unless /^\t0x(\S+)/;
1.105 + my $value = hex $1;
1.106 +
1.107 + # Ignore low bits, unless they've specified --noslop
1.108 + $value &= ~0x7 unless $noslop;
1.109 +
1.110 + $slots[$#slots + 1] = $value;
1.111 + }
1.112 +
1.113 + $object->{'slots'} = \@slots;
1.114 +
1.115 + # Record the stack by which the object was allocated
1.116 + my @stack;
1.117 +
1.118 + while (/^(.*)\[(.*) \+0x(\S+)\]$/) {
1.119 + # e.g., _dl_debug_message[/lib/ld-linux.so.2 +0x0000B858]
1.120 + my ($func, $lib, $off) = ($1, $2, hex $3);
1.121 +
1.122 + chomp;
1.123 + $stack[$#stack + 1] = $_;
1.124 +
1.125 + $_ = <>;
1.126 + }
1.127 +
1.128 + $object->{'stack'} = \@stack;
1.129 +
1.130 + $object->{'type'} = infer_type(\@stack)
1.131 + if $object->{'type'} eq 'void*';
1.132 +
1.133 + &$callback($object) if $callback;
1.134 +
1.135 + # Gotta check EOF explicitly...
1.136 + last OBJECT if eof;
1.137 + }
1.138 +}
1.139 +
1.140 +1;
1.141 +__END__
1.142 +
1.143 +=head1 NAME
1.144 +
1.145 +TraceMalloc - Perl routines to deal with output from ``trace malloc''
1.146 +and the Boehm GC
1.147 +
1.148 +=head1 SYNOPSIS
1.149 +
1.150 + use TraceMalloc;
1.151 +
1.152 + TraceMalloc::init_type_inference("types.dat");
1.153 + TraceMalloc::read(0);
1.154 +
1.155 +=head1 DESCRIPTION
1.156 +
1.157 +=head1 EXAMPLES
1.158 +
1.159 +=cut
