]>
Commit | Line | Data |
---|---|---|
e5433948 AR |
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 | } |