scripts/trace-entry.pl

   1 #!/usr/bin/perl -w
   2
   3 # Reads cache.log and displays lines that correspond to a given store entry.
   4 #
   5 # Store entry can be identified by its key or an anchor slot ID in a rock-style
   6 # map.
   7 #
   8 # Currently, the script reads and remembers many irrelevant lines because it
   9 # does not know which one should be tracked in advance.
  10 #
  11
  12 use strict;
  13 use warnings;
  14 use Carp;
  15
  16 my @InterestingEntries = @ARGV;
  17 #die("usage: $0 [entry number|key value|pointer address] ...\n");
  18
  19 my $LastEntryId = 0;
  20 my %Entries = ();
  21 my %EntriesByPartId = ();
  22
  23 my %CurrentEntries = ();
  24 my $Kid;
  25 my %Entering = ();
  26 my %Inside = ();
  27
  28 my $DEB;
  29
  30 while (<STDIN>) {
  31         my $line = $_;
  32         #$DEB = 1 if /16:53:44.632/;
  33
  34         ($Kid) = (/(kid\d+)[|]/);
  35         $Kid = 'kid0' unless defined $Kid;
  36
  37         &enterBlock($., $_) if
  38                 (/[|:] entering\b/ && !/Port::noteRead/) ||
  39         (/Port::noteRead/ && /handling/);
  40
  41         next unless $Inside{$Kid};
  42
  43         while ($line =~ s@\b(entry) (\d+) .*?(\S*_map)@ @) {
  44                 &processEntryPartId("$3.$1", $2);
  45         }
  46
  47         while ($line =~ s@\b(slice|slot) (\d+)@ @) {
  48                 &processEntryPartId($1, $2);
  49         }
  50
  51         #while ($line =~ s@\b(page) (\w+)@ @) {
  52         #       &processEntryPartId($1, $2);
  53         #}
  54
  55         while ($line =~ s@\b(key) '?(\w+)@ @) {
  56                 &processEntryPartId($1, $2);
  57         }
  58
  59         while ($line =~ s@\b([A-Z0-9]{32})\b@ @) {
  60                 &processEntryPartId('key', $1);
  61         }
  62
  63         while ($line =~ s@\be:\S*?/(0x\w+)@ @ || $line =~ s@\bStoreEntry\s+(0x\w+)@ @) {
  64                 &processEntryPartId('pointer', $1);
  65         }
  66
  67         if ($line ne $_ || /[|:] leaving\b/) {
  68                 if (my $entry = $CurrentEntries{$Kid}) {
  69                         &updateEntry($entry, $Entering{$Kid}) if exists $Entering{$Kid};
  70                         delete $Entering{$Kid};
  71                         &updateEntry($entry, &historyLine($., $_));
  72                 }
  73         }
  74
  75         &leaveBlock() if
  76        (/[|:] leaving\b/ && !/Port::noteRead/) ||
  77         (/Port::noteRead/ && /handled/);
  78 }
  79
  80
  81 # merge same entries
  82 my %cleanEntries = ();
  83 foreach my $id (sort { $a <=> $b } keys %Entries) {
  84         my $entry = $Entries{$id};
  85
  86         next unless &mergeAllLinkedEntries($entry);
  87
  88         $entry->{id} = 1 + scalar keys %cleanEntries;
  89         $cleanEntries{$entry->{id}} = $entry;
  90 }
  91 %Entries = %cleanEntries;
  92
  93 printf("Saw %d entries\n", scalar keys %Entries);
  94
  95 if (!@InterestingEntries) { # print all entries
  96         foreach my $id (sort { $a <=> $b } keys %Entries) {
  97                 my $entry = $Entries{$id};
  98                 reportEntry($entry, 1);
  99         }
 100 } else {
 101         foreach my $description (@InterestingEntries) {
 102                 my ($part, $id) = ($description =~ /(\w+)\s+(\w+)/);
 103                 my $entry = &getExistingEntry($part, $id);
 104                 reportEntry($entry, 1);
 105         }
 106 }
 107
 108 exit(0);
 109
 110 sub enterBlock {
 111         my ($lineNo, $lineText) = @_;
 112
 113         $Entering{$Kid} = &historyLine($., $_);
 114         die("double entrance, stopped") if $Inside{$Kid};
 115         $Inside{$Kid} = 1;
 116 }
 117
 118 sub leaveBlock {
 119         $CurrentEntries{$Kid} = undef();
 120         delete $Entering{$Kid};
 121         $Inside{$Kid} = 0;
 122 }
 123
 124 sub processEntryPartId {
 125         my ($part, $id) = @_;
 126
 127         #warn("XXX1: $Kid| part.id: $part.$id\n") if $DEB;
 128
 129         my $entry;
 130         my $curEntry = $CurrentEntries{$Kid};
 131         my $oldEntry = &getExistingEntry($part, $id);
 132         if ($curEntry && $oldEntry && $curEntry->{id} != $oldEntry->{id}) {
 133                 &linkEntries($curEntry, $oldEntry, "$part.$id");
 134                 $entry = $curEntry;
 135         } else {
 136                 $entry = $curEntry ? $curEntry : $oldEntry;
 137         }
 138         $entry = &getEntry($part, $id) unless defined $entry;
 139         $CurrentEntries{$Kid} = $entry;
 140
 141         $entry->{parts}->{$part} = {} unless exists $entry->{parts}->{$part};
 142         $entry->{parts}->{$part}->{$id} = $_ unless exists $entry->{parts}->{$part}->{$id};
 143 }
 144
 145 sub historyLine {
 146         my ($lineCount, $line) = @_;
 147         return sprintf("#%06d %s", $lineCount, $line);
 148 }
 149
 150 sub updateEntry {
 151         my ($entry, $historyLine) = @_;
 152
 153         $entry->{history} .= $historyLine;
 154 }
 155
 156 sub linkEntries {
 157         my ($e1, $e2, $ctx) = @_;
 158
 159         $e1->{sameAs}->{$e2->{id}} = 1;
 160         $e2->{sameAs}->{$e1->{id}} = 1;
 161 }
 162
 163 sub mergeAllLinkedEntries {
 164         my ($entry) = @_;
 165
 166         #warn(sprintf("merging %d <-- * %s\n", $entry->{id}, $entry->{merged} ? "skipped" : ""));
 167
 168         return 0 if $entry->{merged};
 169         $entry->{merged} = 1;
 170
 171         foreach my $otherId (keys %{$entry->{sameAs}}) {
 172                 my $otherE = $Entries{$otherId};
 173                 die("missing internal entry$otherId, stopped") unless $otherE;
 174                 next if $otherE->{merged};
 175                 &mergeAllLinkedEntries($otherE);
 176                 &mergeOneEntry($entry, $otherE);
 177                 $otherE->{merged} = 1;
 178         }
 179
 180         return 1;
 181 }
 182
 183 sub mergeOneEntry {
 184         my ($entry, $otherE) = @_;
 185
 186         #warn(sprintf("merging %d <-- %d\n", $entry->{id}, $otherE->{id}));
 187
 188         foreach my $part (keys %{$otherE->{parts}}) {
 189         foreach my $id (keys %{$otherE->{parts}->{$part}}) {
 190             $entry->{parts}->{$part}->{$id} = $otherE->{parts}->{$part}->{$id};
 191                 }
 192         }
 193
 194         $entry->{history} .= $otherE->{history};
 195 }
 196
 197 sub getExistingEntry {
 198         my ($part, $id) = @_;
 199
 200         return $EntriesByPartId{$part}->{$id} if exists $EntriesByPartId{$part};
 201         return undef();
 202 }
 203
 204 sub getEntry {
 205         my ($part, $id) = @_;
 206
 207         $EntriesByPartId{$part} = {} unless exists $EntriesByPartId{$part};
 208         my $entry = $EntriesByPartId{$part}->{$id};
 209         return $entry if $entry;
 210
 211         $entry = {
 212                 id => ++$LastEntryId,
 213
 214                 parts => {},
 215
 216                 history => '',
 217
 218                 reported => 0,
 219         };
 220
 221         $entry->{parts}->{$part} = {};
 222         $EntriesByPartId{$part}->{$id} = $entry;
 223         $Entries{$LastEntryId} = $entry;
 224         return $entry;
 225 }
 226
 227
 228 sub reportEntry {
 229         my ($entry, $recursive) = @_;
 230
 231         return if $entry->{reported};
 232         $entry->{reported} = 1;
 233
 234         printf("entry%d:\n", $entry->{id});
 235
 236         foreach my $part (keys %{$entry->{parts}}) {
 237                 printf("\t%s(s):", $part);
 238                 foreach my $id (keys %{$entry->{parts}->{$part}}) {
 239                         printf(" %s", $id);
 240                 }
 241                 print("\n");
 242         }
 243
 244         &reportEntryHistory($entry);
 245 }
 246
 247 sub reportEntryParam {
 248         my ($entry, $name, $value) = @_;
 249
 250         $value = $entry->{$name} if @_ < 3;
 251         $value = '?' unless defined $value;
 252         $value = "\n$value" if $value =~ /\n/m;
 253         printf("\t%s: %s\n", $name, $value);
 254 }
 255
 256 sub reportEntryHistory {
 257         my ($entry) = @_;
 258
 259         my $history = $entry->{history};
 260         my @lines = split(/\n/, $history);
 261         &reportEntryParam($entry, 'history', (scalar @lines) . " lines");
 262
 263         my $lastKid = '';
 264         foreach my $line (sort @lines) {
 265                 my ($kid) = ($line =~ /(kid\d+)[|]/);
 266                 $kid = 'kid0' unless defined $kid;
 267
 268                 print "\n" if $lastKid ne $kid;
 269                 print "$line\n";
 270                 $lastKid = $kid;
 271         }
 272         print "\n" if @lines;
 273 }