tools/dev/gen_valgrind_suppressions.pl

   1 #! perl
   2
   3 # Copyright (C) 2009, Parrot Foundation.
   4 # $Id$
   5
   6 use strict;
   7 use warnings;
   8 use IO::File;
   9
  10 # This is written with unix-like systems very much in mind.  Feel free to
  11 # update this if/when valgrind is ported to other platforms.
  12 die "Must be run in (built) parrot source directory.\n" unless -f 'parrot';
  13
  14 # create t/op/say_1.pir if necessary
  15 `prove t/op/say.t` unless -f 't/op/say_1.pir';
  16
  17 my $pipe = IO::File->new( "valgrind --suppressions=tools/dev/parrot.supp"
  18                          ." --freelist-vol=1000000000 --num-callers=500"
  19                          ." --leak-check=full --leak-resolution=high"
  20                          ." --show-reachable=yes ./parrot --leak-test"
  21                          ." t/op/say_1.pir 2>&1 |" );
  22
  23 # simple state machine.
  24 my ($line, $type);
  25 while(defined($line = $pipe->getline)) {
  26     chomp($line);
  27     if($line =~ /^==(\d+)== (.+)$/) {
  28         my ($pid, $message) = ($1, $2);
  29         if($message eq 'Conditional jump or move depends on uninitialised value(s)') {
  30             $type = 'Cond';
  31         }
  32         if($message eq 'Use of uninitialised value of size 8') {
  33             $type = 'Value8';
  34         }
  35         if($message eq 'Use of uninitialised value of size 4') {
  36             $type = 'Value4';
  37         }
  38         elsif($message =~ /   at (0x[0-9A-F]+): (\S+) \((.+)\)$/) {
  39             my ($offset, $symbol, $object) = ($1, $2, $3);
  40             if($object =~ m|in /lib[^/]*/ld-.+\.so$|) {
  41                 # suppress GNU ld error.
  42                 my $supp_name = lc("gnuld-$symbol-$type");
  43                 $supp_name =~ s/[-_]+/-/g;
  44                 emit($supp_name, $symbol, "Memcheck:$type", '/lib*/ld-*.so');
  45             }
  46         }
  47     }
  48 }
  49
  50 my %already_emitted;
  51 sub emit {
  52     my ($name, $symbol, $type, $object) = @_;
  53     return if exists($already_emitted{$name});
  54     print("{\n");
  55     print("   $name\n");
  56     print("   $type\n");
  57     print("   fun:$symbol\n");
  58     print("   obj:$object\n");
  59     print("}\n");
  60     $already_emitted{$name} = 1;
  61 }
  62
  63 # Local Variables:
  64 #   mode: cperl
  65 #   cperl-indent-level: 4
  66 #   fill-column: 100
  67 # End:
  68 # vim: expandtab shiftwidth=4: