trace/curallocs.pl

   1 #!/usr/bin/perl -w
   2
   3 # Show current allocations from a trace file. If run over a trace file
   4 # from a program which has exited, this will show memory leaks. If run
   5 # over a trace file for a program which is currently running, this will
   6 # show currently allocated space.
   7 #
   8 # By Richard W.M. Jones <rich@annexia.org>
   9 #
  10 # $Id: curallocs.pl,v 1.1 2001/02/08 12:51:35 rich Exp $
  11
  12 use strict;
  13
  14 my %pools = ();
  15
  16 my $lineno = 0;
  17
  18 while (<>)
  19   {
  20     $lineno++;
  21
  22     s/[\n\r]+$//;
  23
  24     if (/^([a-z_]+)\s+caller:\s+([0-9a-fx]+)\s+ptr1:\s+([0-9a-fx]+|\(nil\))\s+ptr2:\s+([0-9a-fx]+|\(nil\))\s+ptr3:\s+([0-9a-fx]+|\(nil\))\s+i1:\s+([0-9]+)\s*$/)
  25       {
  26         my $fn = $1;
  27         my $caller = $2;
  28         my $ptr1 = $3 ne '(nil)' ? $3 : 0;
  29         my $ptr2 = $4 ne '(nil)' ? $4 : 0;
  30         my $ptr3 = $5 ne '(nil)' ? $4 : 0;
  31         my $i1 = $6;
  32
  33         if ($fn eq "new_pool")
  34           {
  35             die "new_pool: pool exists, line $lineno"
  36               if exists $pools{$ptr1};
  37
  38             $pools{$ptr1} = {
  39                              creator => $caller,
  40                              pool => $ptr1,
  41                              children => {},
  42                              allocations => {}
  43                             };
  44           }
  45         elsif ($fn eq "new_subpool")
  46           {
  47             die "new_subpool: pool exists, line $lineno"
  48               if exists $pools{$ptr1};
  49
  50             $pools{$ptr1} = {
  51                              creator => $caller,
  52                              pool => $ptr1,
  53                              parent => $ptr2,
  54                              children => {},
  55                              allocations => {}
  56                             };
  57             $pools{$ptr2}{children}{$ptr1} = 1;
  58           }
  59         elsif ($fn eq "delete_pool")
  60           {
  61             if ($pools{$ptr1}{parent})
  62               {
  63                 delete $pools{$pools{$ptr1}{parent}}{children}{$ptr1};
  64               }
  65
  66             remove_pool_recursively ($ptr1);
  67           }
  68         elsif ($fn eq "pmalloc")
  69           {
  70             die "pmalloc: no pool $ptr1, line $lineno"
  71               unless exists $pools{$ptr1};
  72
  73             $pools{$ptr1}{allocations}{$ptr2} = {
  74                                                  creator => $caller,
  75                                                  pool => $ptr1,
  76                                                  address => $ptr2,
  77                                                  size => $i1
  78                                                 };
  79           }
  80         elsif ($fn eq "prealloc")
  81           {
  82             die "prealloc: no pool $ptr1, line $lineno"
  83               unless exists $pools{$ptr1};
  84             die "prealloc: allocation already exists, line $lineno"
  85               unless exists $pools{$ptr1}{allocations}{$ptr2};
  86
  87             # Delete the old allocation.
  88             delete $pools{$ptr1}{allocations}{$ptr2};
  89
  90             $pools{$ptr1}{allocations}{$ptr3} = {
  91                                                  creator => $caller,
  92                                                  pool => $ptr1,
  93                                                  address => $ptr3,
  94                                                  size => $i1
  95                                                 };
  96           }
  97         else
  98           {
  99             die "unknown pool function traced: $fn, line $lineno";
 100           }
 101       }
 102     else
 103       {
 104         print "$lineno: $_\n";
 105         die "cannot parse line";
 106       }
 107   }
 108
 109 if (keys %pools > 0) {
 110   show_pools ();
 111 } else {
 112   print "No pools are currently allocated.\n";
 113 }
 114
 115 exit 0;
 116
 117 sub remove_pool_recursively
 118   {
 119     my $pool = shift;
 120     local $_;
 121
 122     die unless exists $pools{$pool};
 123
 124     # Remove children first.
 125     foreach (keys %{$pools{$pool}{children}})
 126       {
 127         remove_pool_recursively ($_);
 128       }
 129
 130     delete $pools{$pool};
 131   }
 132
 133 sub show_pools
 134   {
 135     local $_;
 136
 137     foreach (keys %pools)
 138       {
 139         show_pool ($_);
 140       }
 141   }
 142
 143 sub show_pool
 144   {
 145     my $pool = shift;
 146     my $indent = shift || 0;
 147     local $_;
 148
 149     my $sp = " " x $indent;
 150
 151     print $sp, "pool $pool created by $pools{$pool}{creator}:\n";
 152     print $sp, "  number of direct allocations: ", 0 + keys %{$pools{$pool}{allocations}}, "\n";
 153     print $sp, "  number of children: ", 0 + keys %{$pools{$pool}{children}}, "\n";
 154     print $sp, "  allocations:\n";
 155
 156     show_allocations ($pools{$pool}{allocations}, $indent);
 157
 158     print $sp, "  children:\n";
 159
 160     foreach (keys %{$pools{$pool}{children}})
 161       {
 162         show_pool ($_, $indent + 2);
 163       }
 164   }
 165
 166 sub show_allocations
 167   {
 168     my $allocations = shift;
 169     my $indent = shift || 0;
 170     local $_;
 171
 172     foreach (keys %$allocations)
 173       {
 174         show_allocation ($allocations->{$_}, $indent);
 175       }
 176   }
 177
 178 sub show_allocation
 179   {
 180     my $allocation = shift;
 181     my $indent = shift || 0;
 182     local $_;
 183
 184     my $sp = " " x $indent;
 185
 186     print $sp, "    allocation $allocation->{address} created by $allocation->{creator} size $allocation->{size}\n";
 187   }