The Tor Browser / file comparison
comparison: tools/trace-malloc/TraceMalloc.pm
tools/trace-malloc/TraceMalloc.pm
- branch
- TOR_BUG_9701
- changeset 15
- b8a032363ba2
equal
deleted
inserted
replaced
| -1:000000000000 | 0:0d7be487249b |
|---|---|
| 1 # This Source Code Form is subject to the terms of the Mozilla Public | |
| 2 # License, v. 2.0. If a copy of the MPL was not distributed with this | |
| 3 # file, You can obtain one at http://mozilla.org/MPL/2.0/. | |
| 4 package TraceMalloc; | |
| 5 | |
| 6 use strict; | |
| 7 | |
| 8 # Read in the type inference file and construct a network that we can | |
| 9 # use to match stack prefixes to types. | |
| 10 sub init_type_inference($) { | |
| 11 my ($file) = @_; | |
| 12 | |
| 13 $::Fingerprints = { }; | |
| 14 | |
| 15 open(TYPES, "<$file") || die "unable to open $::opt_types, $!"; | |
| 16 | |
| 17 TYPE: while (<TYPES>) { | |
| 18 next TYPE unless /<(.*)>/; | |
| 19 my $type = $1; | |
| 20 | |
| 21 my $link = \%::Fingerprints; | |
| 22 | |
| 23 FRAME: while (<TYPES>) { | |
| 24 chomp; | |
| 25 last FRAME if /^$/; | |
| 26 | |
| 27 my $next = $link->{$_}; | |
| 28 if (! $next) { | |
| 29 $next = $link->{$_} = {}; | |
| 30 } | |
| 31 $link = $next; | |
| 32 } | |
| 33 | |
| 34 $link->{'#type#'} = $type; | |
| 35 | |
| 36 last TYPE if eof; | |
| 37 } | |
| 38 } | |
| 39 | |
| 40 # Infer the type, trying to find the most specific type possible. | |
| 41 sub infer_type($) { | |
| 42 my ($stack) = @_; | |
| 43 | |
| 44 my $link = \%::Fingerprints; | |
| 45 my $last; | |
| 46 my $type = 'void*'; | |
| 47 FRAME: foreach my $frame (@$stack) { | |
| 48 last FRAME unless $link; | |
| 49 | |
| 50 $frame =~ s/\[.*\]$//; # ignore exact addresses, as they'll drift | |
| 51 | |
| 52 $last = $link; | |
| 53 | |
| 54 # | |
| 55 # Remember this type, but keep going. We use the longest match | |
| 56 # we find, but substacks of longer matches will also match. | |
| 57 # | |
| 58 if ($last->{'#type#'}) { | |
| 59 $type = $last->{'#type#'}; | |
| 60 } | |
| 61 | |
| 62 $link = $link->{$frame}; | |
| 63 | |
| 64 if (! $link) { | |
| 65 CHILD: foreach my $child (keys %$last) { | |
| 66 next CHILD unless $child =~ /^~/; | |
| 67 | |
| 68 $child =~ s/^~//; | |
| 69 | |
| 70 if ($frame =~ $child) { | |
| 71 $link = $last->{'~' . $child}; | |
| 72 last CHILD; | |
| 73 } | |
| 74 } | |
| 75 } | |
| 76 } | |
| 77 | |
| 78 return $type; | |
| 79 } | |
| 80 | |
| 81 | |
| 82 #---------------------------------------------------------------------- | |
| 83 # | |
| 84 # Read in the output a trace malloc's dump. | |
| 85 # | |
| 86 sub read { | |
| 87 my ($callback, $noslop) = @_; | |
| 88 | |
| 89 OBJECT: while (<>) { | |
| 90 # e.g., 0x0832FBD0 <void*> (80) | |
| 91 next OBJECT unless /^0x(\S+) <(.*)> \((\d+)\)/; | |
| 92 my ($addr, $type, $size) = (hex $1, $2, $3); | |
| 93 | |
| 94 my $object = { 'type' => $type, 'size' => $size }; | |
| 95 | |
| 96 # Record the object's slots | |
| 97 my @slots; | |
| 98 | |
| 99 SLOT: while (<>) { | |
| 100 # e.g., 0x00000000 | |
| 101 last SLOT unless /^\t0x(\S+)/; | |
| 102 my $value = hex $1; | |
| 103 | |
| 104 # Ignore low bits, unless they've specified --noslop | |
| 105 $value &= ~0x7 unless $noslop; | |
| 106 | |
| 107 $slots[$#slots + 1] = $value; | |
| 108 } | |
| 109 | |
| 110 $object->{'slots'} = \@slots; | |
| 111 | |
| 112 # Record the stack by which the object was allocated | |
| 113 my @stack; | |
| 114 | |
| 115 while (/^(.*)\[(.*) \+0x(\S+)\]$/) { | |
| 116 # e.g., _dl_debug_message[/lib/ld-linux.so.2 +0x0000B858] | |
| 117 my ($func, $lib, $off) = ($1, $2, hex $3); | |
| 118 | |
| 119 chomp; | |
| 120 $stack[$#stack + 1] = $_; | |
| 121 | |
| 122 $_ = <>; | |
| 123 } | |
| 124 | |
| 125 $object->{'stack'} = \@stack; | |
| 126 | |
| 127 $object->{'type'} = infer_type(\@stack) | |
| 128 if $object->{'type'} eq 'void*'; | |
| 129 | |
| 130 &$callback($object) if $callback; | |
| 131 | |
| 132 # Gotta check EOF explicitly... | |
| 133 last OBJECT if eof; | |
| 134 } | |
| 135 } | |
| 136 | |
| 137 1; | |
| 138 __END__ | |
| 139 | |
| 140 =head1 NAME | |
| 141 | |
| 142 TraceMalloc - Perl routines to deal with output from ``trace malloc'' | |
| 143 and the Boehm GC | |
| 144 | |
| 145 =head1 SYNOPSIS | |
| 146 | |
| 147 use TraceMalloc; | |
| 148 | |
| 149 TraceMalloc::init_type_inference("types.dat"); | |
| 150 TraceMalloc::read(0); | |
| 151 | |
| 152 =head1 DESCRIPTION | |
| 153 | |
| 154 =head1 EXAMPLES | |
| 155 | |
| 156 =cut |
