source: tags/ms_r16q2/SOURCE_TOOLS/valgrind2grep

Last change on this file was 12345, checked in by westram, 10 years ago
  • suppress several leaks caused by arbs motif usage
    • previously these just were "ignored" in output by valgrind2grep (removed them there)
  • Property svn:eol-style set to native
  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 10.6 KB
Line 
1#!/usr/bin/perl
2
3use warnings;
4use strict;
5use IO::Handle;
6
7# -------------------------------------------------------------------- customize here
8
9# top source directory
10my $topdir = "$ENV{ARBHOME}";
11my $toplen = length($topdir);
12
13# list containing paths of all source files (generated by arb_valgrind)
14my $sourcelist = "$topdir/SOURCE_TOOLS/valgrind2grep.lst";
15
16# prefix to write before hidden caller-lines
17# (-> emacs will not jump to them automatically, you have to remove the prefix first)
18my $unmark_callers  = "(hide) ";
19
20# prefix to write before filtered lines
21my $unmark_filtered = "(filt) ";
22
23# prefix to write before other non-error lines
24my $unmark_rest     = "(note) ";
25
26sub check_ignore_internal($\$$) {
27  my ($text,$ignore_r,$reason) = @_;
28  if (not defined $$ignore_r) {
29    # defines ignored leaks/errors occurring in internal libraries (wontfixes)
30    # To ignore them add a search expression here.
31    # Please add current date as well, to make it easier to find outdated expressions.
32
33    # print "check_ignore_internal: reason='$reason'\n";
34
35    if ($reason =~ 'loss record') { # memory leaks
36      if ($reason =~ 'still reachable' or $reason =~ 'possibly lost') { # reachable memory leaks
37        # things broken in ARB motif (wontfix; remove these exclusions after gtk merge)
38        if ($text =~ /\b(gbmGetMemImpl)\b/) { $$ignore_r = $&; return; } # 04/12/2013 -- not all blocks of internal mem.management were freed (set MEMORY_TEST 1 in gb_memory.h to find leakers)
39        ;
40      }
41      elsif ($reason =~ 'definitely lost') { # unreachable memory leaks
42        if ($text =~ /\b(awt_create_selection_list_on_(trees|alignments))\b/) { $$ignore_r = $&; return; } # 03/12/2013
43        ;
44      }
45    }
46    elsif ($reason =~ 'file descriptor') { # open file descriptors
47      if ($text =~ /\b(aw_initstatus)\b/) { $$ignore_r = $&; return; } # 03/12/2013
48      ;
49    }
50    # else { # illegal memory access
51    # }
52  }
53}
54
55
56
57sub is_boring($) {
58  my ($text) = @_;
59  if ($text =~ /provoke_core_dump/) { return 1; }
60  return 0;
61}
62
63my $debug = 0;
64
65# --------------------------------------------------------------- customize till here
66
67# get args:
68
69my $args = scalar(@ARGV);
70
71if ($args<2 or $args>3) { die "Usage: valgrind2grep <callers> <filter> [--suppress-common]\n"; }
72my $callers = $ARGV[0];
73my $filter  = $ARGV[1];
74
75my $suppress_common = 0;
76if ($args==3) {
77  my $a = $ARGV[2];
78  if ($a eq '--suppress-common') { $suppress_common=1; }
79  else { die "Unknown argument '$a'"; }
80}
81
82# use unbuffered I/O (otherwise pipe waits for valgrind to terminate???)
83
84my $in = new IO::Handle;
85$in->fdopen(fileno(STDIN),"r") || die "can't open STDIN";
86
87my $out = new IO::Handle;
88$out->fdopen(fileno(STDOUT),"w") || die "can't open STDOUT";
89
90# read list of source files:
91
92open(SOURCELIST,"<$sourcelist") || die "can't open $sourcelist";
93
94my %fileIndex = ();
95
96sub addFileIndex($$) {
97  my ($key,$val) = @_;
98  if (not exists $fileIndex{$key}) {
99    my @array = ();
100    $fileIndex{$key} = \@array;
101  }
102  my $array_r = $fileIndex{$key};
103  push @$array_r, $val;
104}
105
106foreach (<SOURCELIST>) {
107  chomp;
108  addFileIndex($_,$_);
109  if (/\/([^\/]+)\/([^\/]+)$/) {
110    my $last_dir = $1;
111    my $fname    = $2;
112
113    addFileIndex($fname,$_);
114    addFileIndex($last_dir.'/'.$fname,$_);
115  }
116  elsif (/\/([^\/]+)$/) {
117    my $fname = $1;
118    addFileIndex($fname,$_);
119  }
120  else {
121    die "invalid entry in $sourcelist ('$_')"
122  }
123}
124
125close(SOURCELIST);
126
127sub parentDir($) {
128  my ($dirOrFile) = @_;
129  if ($dirOrFile =~ /\/[^\/]+$/o) { return $`; }
130  return undef;
131}
132
133sub makeTargetAbsolute($$) {
134  my ($abslink,$reltarget) = @_;
135  my $absdir = parentDir($abslink);
136  if (defined $absdir) {
137    while ($reltarget =~ /^\.\.\//o) {
138      $reltarget = $';
139      my $absparent = parentDir($absdir);
140      if (defined $absparent) {
141        $absdir = $absparent;
142      }
143      else {
144        die "Can't detect parent dir of '$absdir'";
145      }
146    }
147
148    my $result = $absdir.'/'.$reltarget;
149    return $result;
150  }
151  else {
152    die "Can't detect parent dir of '$abslink'";
153  }
154}
155
156# make entries unique
157foreach (keys %fileIndex) {
158  my $array_r = $fileIndex{$_};
159  my %unique = map { $_ => 1; } @$array_r;
160
161  my $changed = 1;
162  while ($changed==1) {
163    $changed = 0;
164    my @del = ();
165    my @add = ();
166    foreach (keys %unique) {
167      my $target = undef;
168      eval { $target = readlink($_); };
169      if ($@) {                 # a link with invalid target?
170        push @del, $_;
171        $out->print("Remove invalid link '$_' (Reason: $!)\n");
172      }
173      elsif (defined $target) { # a link with valid target
174        $target = makeTargetAbsolute($_,$target);
175        push @del, $_;
176        push @add, $target;
177        # $out->print("Replace link '$_'\n   by target '$target'\n");
178        # $out->print("Target '$target' exists:".(-e $target ? 'yes' : 'no')."\n");
179      }
180      # else not a link
181    }
182    if (scalar(@del)) { foreach (@del) { delete $unique{$_}; } $changed=1; }
183    if (scalar(@add)) { foreach (@add) { $unique{$_} = 1; } $changed=1; }
184  }
185  @$array_r = keys %unique;
186}
187
188
189$out->print("Settings: Showing $callers caller(s).\n");
190$out->print("          Filtering with '$filter'.\n");
191
192sub avoid_location($) {         # invalidate everything emacs could missinterpret as error-location (i.e. '(file:lineno)')
193  ($_) = @_;
194  s/([(].*)(:)(.*[)])/$1_$2_$3/ig;
195  $_;
196}
197
198my $reg_topdir = qr/^$topdir\//o;
199
200sub shorten_location($) {
201  my ($locline) = @_;
202  if ($locline =~ /^([^:]+):([0-9]+):/o) {
203    my ($loc,$line,$msg) = ($1,$2,$');
204    if ($loc =~ $reg_topdir) {
205      $loc = $';
206    }
207    $locline = $loc.':'.$line.':'.$msg;
208  }
209  $locline;
210}
211
212my $entered=0;
213
214sub entering() {
215  if ($entered==0) {
216    $out->print('vake[2]: Entering directory `'.$topdir."\'\n");
217    $entered = 1;
218  }
219}
220sub leaving() {
221  if ($entered==1) {
222    $out->print('vake[2]: Leaving directory `'.$topdir."\'\n");
223    $entered = 0;
224  }
225}
226
227sub hideMessages($\@) {
228  my ($hidePrefix,$outstack_r) = @_;
229  $hidePrefix = "($hidePrefix) ";
230  @$outstack_r = map { $hidePrefix.$_; } @$outstack_r;
231}
232
233# variables:
234
235my $i;
236my $called_from       = "called from";
237my $reason            = 'no reason yet';
238my $non_caller_reason = 'no reason yet';
239my $caller_count      = 0;       # counts callers
240my $filtered          = 0;       # filter current error
241my $ignore            = undef;
242my $last_ignore       = '';
243my $ignore_curr_line  = 0;
244
245# the filter loop:
246
247my @outstack = ();
248
249while (not $in->eof) {
250  # read one line:
251  $_ = $in->getline;
252
253  # convert error messages to grep format:
254  if (/^([=\-0-9]+[ ]+)(.*)$/) {
255    my $prefix  = $1;
256    my $content = $2;
257
258    if ($content =~ /^([ab][ty].*)([(][^()]+[)])$/) { # looks like an valgrind error
259      $content = $1;
260      my $location = $2;
261
262      if ($location =~ /[(](.*):(.*)[)]/) { # seems to have a valid '(file:line)' location at eol
263        my ($file,$line) = ($1,$2);
264        if ($filtered == 1) {
265          $_ = $unmark_filtered.' '.&avoid_location($_);
266        }
267        else {
268          my $array_r = $fileIndex{$file};
269          if (defined $array_r) {
270            my @lines = ();
271            if (scalar(@$array_r)>1) {
272              push @lines, $unmark_rest."Multiple occurrences of '$file' - not sure which location is the correct one\n";
273            }
274
275            if ($reason eq $called_from) { # its a caller
276              $caller_count++;
277            }
278            else {
279              $caller_count = 0;
280            }
281
282            foreach my $replace (@$array_r) {
283              if (not -f $replace) {
284                $_ = "$sourcelist:1: might be outdated ($replace does not exist)\n";
285              }
286              else {
287                $_ = "$replace:$line: $reason ($content)\n";
288                if ($caller_count > $callers) {
289                  $_ = $unmark_callers.$_;
290                }             # hide this caller
291              }
292              push @lines, $_;
293            }
294
295            $reason = $called_from;
296            $_ = join '', @lines;
297          }
298          else {                # location in unavailable file (i.e. in library)
299            $_ = $unmark_rest.$prefix.$reason." $content (in unavailable file $file line $line)\n";
300          }
301          if ($reason ne $called_from) { $non_caller_reason = $reason; }
302          if ($suppress_common==1) {
303            check_ignore_internal($_, $ignore, $non_caller_reason);
304          }
305        }
306      }
307      else {                    # valgrind error w/o location
308        $non_caller_reason = $reason;
309        $_=$unmark_rest.' '.$_;
310      }
311    }
312    else {                      # no location found
313      if ($content =~ /^TRANSLATE: / or
314          $content =~ /^Reading syms from/ or
315          $content =~ /unhandled CFI instruction/ or # happens since gcc 5.4.2
316          $content =~ /object doesn.t have a/) {
317        $ignore_curr_line = 1;
318      }
319      elsif ($content =~ /^[ ]*$/) {
320        if (defined $ignore) { hideMessages('ign2', @outstack); }
321        foreach my $line (@outstack) { $out->print($line); } @outstack = ();
322        $out->flush;
323
324        $ignore = undef;
325        $_      = '(    ) '.$_;
326      }
327      else {
328        $reason = $content;
329        $_='(    ) '.$_;
330
331        # should that reason be filtered ?
332        if ($reason =~ /alloc\'d/) { # an allocator message (applies to last message) -> so never filter
333          $reason = "ORIGIN: $reason";
334          # keep $ignore like before
335        }
336        else {
337          if ($reason =~ /$filter/i) { $filtered = 0; }
338          else { $filtered = 1; }
339
340          if ($filtered == 1) { $ignore = undef; }
341        }
342        if ($filtered==0) { $non_caller_reason = $reason; }
343      }
344    }
345  }
346
347  my $boring = 0;
348  if ($ignore_curr_line==0) {
349    $boring = $ignore_curr_line = is_boring($_);
350  }
351
352  # print out line
353  if ($ignore_curr_line==0) {
354    if (not defined $ignore) {
355      entering();
356      push @outstack, shorten_location($_);
357      $last_ignore = '';
358    }
359    else { # defined ignore
360      # print "last_ignore='$last_ignore' ignore='$ignore'\n";
361      if ($ignore ne $last_ignore) {
362        hideMessages('ign3', @outstack);
363        foreach my $line (@outstack) { $out->print($line); } @outstack = ();
364
365        s/^\(note\)[ ]*//;
366        $out->print("(igno) '$ignore' ".$_);
367        $out->print("(skip) further messages suppressed\n");
368        $out->flush;
369        $last_ignore = $ignore;
370      }
371      else {
372        if ($debug==1) {
373          $out->print("(comm) ".$_);
374          $out->flush;
375        }
376      }
377    }
378  }
379  else {
380    if ($boring) {
381      $out->print("(BORE) ".$_);
382      $out->flush();
383    }
384    elsif ($debug==1) {
385      $out->print("(SUPP) ".$_);
386      $out->flush();
387    }
388    $ignore_curr_line = 0;
389  }
390}
391
392if (defined $ignore) { hideMessages('ign4', @outstack); }
393foreach my $line (@outstack) { $out->print($line); } @outstack = ();
394leaving();
395$out->flush;
396
397$in->close;
398$out->close;
399
Note: See TracBrowser for help on using the repository browser.