X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=Porting%2Fvalgrindpp.pl;h=5078734dfb591515551326033e7e84e47ee9c8e3;hb=17c79f43379fc059c3c23c26a109c793268b3956;hp=4ae539c5376a2b109d52d04d058246dcf64ecf43;hpb=77c22dc1754c82dd7ac259e768986525130fce5d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/Porting/valgrindpp.pl b/Porting/valgrindpp.pl index 4ae539c..5078734 100644 --- a/Porting/valgrindpp.pl +++ b/Porting/valgrindpp.pl @@ -4,115 +4,255 @@ use File::Find qw(find); use Text::Wrap qw(wrap); use Getopt::Long qw(GetOptions); use Pod::Usage qw(pod2usage); +use Cwd qw(cwd); +use File::Spec; use strict; my %opt = ( - hide => [], - frames => 3, - debug => 0, + frames => 3, + lines => 0, + tests => 0, + top => 0, + verbose => 0, ); -GetOptions( \%opt, - qw( +GetOptions(\%opt, qw( + dir=s + frames=i hide=s@ + lines! output-file=s - frames=i - debug+ - ) ) or pod2usage(2); + tests! + top=i + verbose+ + )) or pod2usage(2); + +# Setup the directory to process +if (exists $opt{dir}) { + $opt{dir} = File::Spec->canonpath($opt{dir}); +} +else { + # Check if we're in 't' + $opt{dir} = cwd =~ /\/t$/ ? '..' : '.'; + + # Check if we're in the right directory + -d "$opt{dir}/$_" or die "$0: must be run from the perl source directory" + . " when --dir is not given\n" + for qw(t lib ext); +} -my %hide; -my $hide_re = join '|', map { /^\w+$/ && ++$hide{$_} ? () : $_ } @{$opt{hide}}; -$hide_re and $hide_re = qr/^(?:$hide_re)$/o; +# Assemble regex for functions whose leaks should be hidden +# (no, a hash won't be significantly faster) +my $hidden = do { local $"='|'; $opt{hide} ? qr/^(?:@{$opt{hide}})$/o : '' }; +# Setup our output file handle +# (do it early, as it may fail) my $fh = \*STDOUT; if (exists $opt{'output-file'}) { $fh = new IO::File ">$opt{'output-file'}" - or die "$opt{'output-file'}: $!\n"; + or die "$0: cannot open $opt{'output-file'} ($!)\n"; } +# These hashes will receive the error and leak summary data: +# +# %error = ( +# error_name => { +# stack_frame => { +# test_script => occurences +# } +# } +# ); +# +# %leak = ( +# leak_type => { +# stack_frames => { +# test_script => occurences +# } +# } # stack frames are separated by '<'s +# ); my(%error, %leak); -find({wanted => \&filter, no_chdir => 1}, '.'); -summary($fh); +# Collect summary data +find({wanted => \&filter, no_chdir => 1}, $opt{dir}); + +# Format the output nicely +$Text::Wrap::columns = 80; +$Text::Wrap::unexpand = 0; + +# Write summary +summary($fh, \%error, \%leak); exit 0; sub summary { - my $fh = shift; + my($fh, $error, $leak) = @_; + my(%ne, %nl, %top); + + # Prepare the data + + for my $e (keys %$error) { + for my $f (keys %{$error->{$e}}) { + my($func, $file, $line) = split /:/, $f; + my $nf = $opt{lines} ? "$func ($file:$line)" : "$func ($file)"; + $ne{$e}{$nf}{count}++; + while (my($k,$v) = each %{$error->{$e}{$f}}) { + $ne{$e}{$nf}{tests}{$k} += $v; + $top{$k}{error}++; + } + } + } + + for my $l (keys %$leak) { + for my $s (keys %{$leak->{$l}}) { + my $ns = join '<', map { + my($func, $file, $line) = split /:/; + /:/ ? $opt{lines} + ? "$func ($file:$line)" : "$func ($file)" + : $_ + } split /{$l}{$s}}) { + $nl{$l}{$ns}{tests}{$k} += $v; + $top{$k}{leak}++; + } + } + } + + # Print the Top N + + if ($opt{top}) { + for my $what (qw(error leak)) { + my @t = sort { $top{$b}{$what} <=> $top{$a}{$what} or $a cmp $b } + grep $top{$_}{$what}, keys %top; + @t > $opt{top} and splice @t, $opt{top}; + my $n = @t; + my $s = $n > 1 ? 's' : ''; + my $prev = 0; + print $fh "Top $n test scripts for ${what}s:\n\n"; + for my $i (1 .. $n) { + $n = $top{$t[$i-1]}{$what}; + $s = $n > 1 ? 's' : ''; + printf $fh " %3s %-40s %3d $what$s\n", + $n != $prev ? "$i." : '', $t[$i-1], $n; + $prev = $n; + } + print $fh "\n"; + } + } + + # Print the real summary - $Text::Wrap::columns = 80; - print $fh "MEMORY ACCESS ERRORS\n\n"; - - for my $e (sort keys %error) { + + for my $e (sort keys %ne) { print $fh qq("$e"\n); - for my $frame (sort keys %{$error{$e}}) { - print $fh ' 'x4, "$frame\n", - wrap(' 'x8, ' 'x8, join ', ', sort keys %{$error{$e}{$frame}}), - "\n"; + for my $frame (sort keys %{$ne{$e}}) { + my $data = $ne{$e}{$frame}; + my $count = $data->{count} > 1 ? " [$data->{count} paths]" : ''; + print $fh ' 'x4, "$frame$count\n", + format_tests($data->{tests}), "\n"; } print $fh "\n"; } - + print $fh "\nMEMORY LEAKS\n\n"; - - for my $l (sort keys %leak) { + + for my $l (sort keys %nl) { print $fh qq("$l"\n); - for my $frames (sort keys %{$leak{$l}}) { + for my $frames (sort keys %{$nl{$l}}) { + my $data = $nl{$l}{$frames}; my @stack = split /{count} > 1 and $stack[-1] .= " [$data->{count} paths]"; print $fh join('', map { ' 'x4 . "$_:$stack[$_]\n" } 0 .. $#stack ), - wrap(' 'x8, ' 'x8, join ', ', sort keys %{$leak{$l}{$frames}}), - "\n\n"; + format_tests($data->{tests}), "\n\n"; } } } +sub format_tests { + my $tests = shift; + my $indent = ' 'x8; + + if ($opt{tests}) { + return wrap($indent, $indent, join ', ', sort keys %$tests); + } + else { + my $count = keys %$tests; + my $s = $count > 1 ? 's' : ''; + return $indent . "triggered by $count test$s"; + } +} + sub filter { - debug(1, "$File::Find::name\n"); + debug(2, "$File::Find::name\n"); - /(.*)\.valgrind$/ or return; + # Only process '*.t.valgrind' files + /(.*)\.t\.valgrind$/ or return; + # Strip all unnecessary stuff from the test name my $test = $1; - $test =~ s/^[.t]\///g; - - my @l = map { chomp; s/^==\d+==\s?//; $_ } - do { my $fh = new IO::File $_ or die "$_: $!\n"; <$fh> }; + $test =~ s/^(?:(?:\Q$opt{dir}\E|[.t])\/)+//; + + debug(1, "processing $test ($_)\n"); + + # Get all the valgrind output lines + my @l = do { + my $fh = new IO::File $_ or die "$0: cannot open $_ ($!)\n"; + # Process outputs can interrupt each other, so sort by pid first + my %pid; local $_; + while (<$fh>) { + chomp; + s/^==(\d+)==\s?// and push @{$pid{$1}}, $_; + } + map @$_, values %pid; + }; + # Setup some useful regexes my $hexaddr = '0x[[:xdigit:]]+'; - my $topframe = qr/^\s+at $hexaddr:\s+/o; - my $address = qr/^\s+Address $hexaddr is \d+ bytes (?:before|inside|after) a block of size \d+/o; - my $leak = qr/^\s*\d+ bytes in \d+ blocks are (still reachable|(?:definite|possib)ly lost)/o; + my $topframe = qr/^\s+at $hexaddr:\s+/; + my $address = qr/^\s+Address $hexaddr is \d+ bytes (?:before|inside|after) a block of size \d+/; + my $leak = qr/^\s*\d+ bytes in \d+ blocks are (still reachable|(?:definite|possib)ly lost)/; for my $i (0 .. $#l) { - $l[$i] =~ $topframe or next; # match on any topmost frame... + $l[$i] =~ $topframe or next; # Match on any topmost frame... $l[$i-1] =~ $address and next; # ...but not if it's only address details - my $line = $l[$i-1]; + my $line = $l[$i-1]; # The error / leak description line my $j = $i; if ($line =~ $leak) { debug(2, "LEAK: $line\n"); - my $kind = $1; - my $inperl = 0; - my @stack; + my $type = $1; # Type of leak (still reachable, ...) + my $inperl = 0; # Are we inside the perl source? (And how deep?) + my @stack; # Call stack - while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+((\w+)\s+\((?:([^:]+:\d+)|[^)]+)\))/o) { - my($frame, $func, $loc) = ($1, $2, $3); - defined $loc && ++$inperl or $inperl && last; - if (exists $hide{$func} or $hide_re && $func =~ $hide_re) { - @stack = (); - last; + while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+(\w+)\s+\((?:([^:]+):(\d+)|[^)]+)\)/o) { + my($func, $file, $lineno) = ($1, $2, $3); + + # If the stack frame is inside perl => increment $inperl + # If we've already been inside perl, but are no longer => leave + defined $file && ++$inperl or $inperl && last; + + # A function that should be hidden? => clear stack and leave + $hidden && $func =~ $hidden and @stack = (), last; + + # Add stack frame if it's within our threshold + if ($inperl <= $opt{frames}) { + push @stack, $inperl ? "$func:$file:$lineno" : $func; } - $inperl <= $opt{frames} and push @stack, $inperl ? $frame : $func; } - @stack and $inperl and $leak{$kind}{join '<', @stack}{$test}++; + # If there's something on the stack and we've seen perl code, + # add this memory leak to the summary data + @stack and $inperl and $leak{$type}{join '<', @stack}{$test}++; } else { debug(1, "ERROR: $line\n"); - while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+(\w+\s+\([^:]+:\d+\))?/o) { + # Simply find the topmost frame in the call stack within + # the perl source code + while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+(?:(\w+)\s+\(([^:]+):(\d+)\))?/o) { if (defined $1) { - $error{$line}{$1}{$test}++; + $error{$line}{"$1:$2:$3"}{$test}++; last; } } @@ -122,7 +262,7 @@ sub filter { sub debug { my $level = shift; - $opt{debug} >= $level and print STDERR @_; + $opt{verbose} >= $level and print STDERR @_; } __END__ @@ -133,8 +273,10 @@ valgrindpp.pl - A post processor for make test.valgrind =head1 SYNOPSIS -valgrindpp.pl [B<--output-file>=I] [B<--frames>=I] -[B<--hide>=I] [B<--debug>] +valgrindpp.pl [B<--dir>=I] [B<--frames>=I] +[B<--hide>=I] [B<--lines>] +[B<--output-file>=I] [B<--tests>] +[B<--top>=I] [B<--verbose>] =head1 DESCRIPTION @@ -148,10 +290,12 @@ errors and memory leaks. =over 4 -=item B<--output-file>=I +=item B<--dir>=I -Redirect the output into I. If this option is not -given, the output goes to I. +Recursively process I<.valgrind> files in I. If this +options is not given, B must be run from +either the perl source or the I directory and will process +all I<.valgrind> files within the distribution. =item B<--frames>=I @@ -169,9 +313,30 @@ have lots of memory leaks. I can also be a regular expression, in which case all leaks with symbols matching the expression are hidden. Can be given multiple times. -=item B<--debug> +=item B<--lines> + +Show line numbers for stack frames. This is useful for further +increasing the error/leak resolution, but makes it harder to +compare different reports using I. + +=item B<--output-file>=I + +Redirect the output into I. If this option is not +given, the output goes to I. + +=item B<--tests> + +List all tests that trigger memory access errors or memory +leaks explicitly instead of only printing a count. + +=item B<--top>=I + +List the top I test scripts for memory access errors +and memory leaks. Set to C<0> for no top-I statistics. + +=item B<--verbose> -Increase debug level. Can be given multiple times. +Increase verbosity level. Can be given multiple times. =back