The Tor Browser: tools/trace-malloc/TraceMalloc.pm@b8a032363ba2

Incorporate requested changes from Mozilla in review:
https://bugzilla.mozilla.org/show_bug.cgi?id=1123480#c6

     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;

     6 use strict;

     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) = @_;

    13     $::Fingerprints = { };

    15     open(TYPES, "<$file") || die "unable to open $::opt_types, $!";

    17   TYPE: while (<TYPES>) {

    18       next TYPE unless /<(.*)>/;

    19       my $type = $1;

    21       my $link = \%::Fingerprints;

    23     FRAME: while (<TYPES>) {

    24         chomp;

    25         last FRAME if /^$/;

    27         my $next = $link->{$_};

    28         if (! $next) {

    29             $next = $link->{$_} = {};

    30         }

    31         $link = $next;

    32     }

    34       $link->{'#type#'} = $type;

    36       last TYPE if eof;

    37   }

    38 }

    40 # Infer the type, trying to find the most specific type possible.

    41 sub infer_type($) {

    42     my ($stack) = @_;

    44     my $link = \%::Fingerprints;

    45     my $last;

    46     my $type = 'void*';

    47   FRAME: foreach my $frame (@$stack) {

    48       last FRAME unless $link;

    50       $frame =~ s/\[.*\]$//; # ignore exact addresses, as they'll drift

    52       $last = $link;

    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       }

    62       $link = $link->{$frame};

    64       if (! $link) {

    65         CHILD: foreach my $child (keys %$last) {

    66             next CHILD unless $child =~ /^~/;

    68             $child =~ s/^~//;

    70             if ($frame =~ $child) {

    71                 $link = $last->{'~' . $child};

    72                 last CHILD;

    73             }

    74           }

    75       }

    76   }

    78     return $type;

    79 }

    82 #----------------------------------------------------------------------

    83 #

    84 # Read in the output a trace malloc's dump.

    85 #

    86 sub read {

    87     my ($callback, $noslop) = @_;

    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);

    94       my $object = { 'type' => $type, 'size' => $size };

    96       # Record the object's slots

    97       my @slots;

    99     SLOT: while (<>) {

   100         # e.g.,      0x00000000

   101         last SLOT unless /^\t0x(\S+)/;

   102         my $value = hex $1;

   104         # Ignore low bits, unless they've specified --noslop

   105         $value &= ~0x7 unless $noslop;

   107         $slots[$#slots + 1] = $value;

   108     }

   110       $object->{'slots'} = \@slots;

   112       # Record the stack by which the object was allocated

   113       my @stack;

   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);

   119           chomp;

   120           $stack[$#stack + 1] = $_;

   122           $_ = <>;

   123       }

   125       $object->{'stack'} = \@stack;

   127       $object->{'type'} = infer_type(\@stack)

   128           if $object->{'type'} eq 'void*';

   130       &$callback($object) if $callback;

   132       # Gotta check EOF explicitly...

   133       last OBJECT if eof;

   134   }

   135 }

   137 1;

   138 __END__

   140 =head1 NAME

   142 TraceMalloc - Perl routines to deal with output from ``trace malloc''

   143 and the Boehm GC

   145 =head1 SYNOPSIS

   147     use TraceMalloc;

   149     TraceMalloc::init_type_inference("types.dat");

   150     TraceMalloc::read(0);

   152 =head1 DESCRIPTION

   154 =head1 EXAMPLES

   156 =cut

The Tor Browser / file revision