Revision: 1192
Author: [email protected]
Date: Wed Apr 21 06:25:45 2010
Log: Refine collapsing of evals to be more useful more often.
Fix reporting of xsub timings that got broken along the way.
Add separator line between main source code and xsub listing.
Fix blank line skipping to not skip past lines that are blank
(e.g., because we don't have source) but do have data to be reported.
Fix html document title that got broken along the way.
http://code.google.com/p/perl-devel-nytprof/source/detail?r=1192
Modified:
/trunk/HACKING
/trunk/bin/nytprofhtml
/trunk/lib/Devel/NYTProf/Data.pm
/trunk/lib/Devel/NYTProf/FileInfo.pm
/trunk/lib/Devel/NYTProf/Reader.pm
/trunk/lib/Devel/NYTProf/SubInfo.pm
=======================================
--- /trunk/HACKING Mon Apr 19 04:08:57 2010
+++ /trunk/HACKING Wed Apr 21 06:25:45 2010
@@ -390,6 +390,7 @@
For eval fid reports:
- Add header with link to location of the invoking string eval
+- Add links to 'sibling' evals
- fix sub caller info to not rollup over evals
- merge string evals which have identical src and invoking location
- fix inconsistency in results of href_for_*() subs
=======================================
--- /trunk/bin/nytprofhtml Wed Apr 21 04:38:30 2010
+++ /trunk/bin/nytprofhtml Wed Apr 21 06:25:45 2010
@@ -114,7 +114,7 @@
For ${ \($profile->{attribute}{application}) }
};
- my $html_header = get_html_header("Profile of !~FILENAME~!");
+ my $html_header = get_html_header("Profile
of ".$fi->filename_without_inc);
my $page_header = get_page_header(
profile => $profile,
title => "NYTProf Performance Profile",
@@ -157,7 +157,8 @@
return sprintf qq{<div class="warn_title">NOTE!</div>\n
<div class="warn">The data used to generate this report page
was merged from %d executions<br />
of the string eval on line %d of %s.<br />
- If the text of those evals varied then this page might not
make much sense.</div><br />\n
+ The source code shown below is the text of just one of the
calls to the eval.<br />\n
+ If the argument source code of those eval calls varied then
this page might not make much sense.</div><br />\n
}, 1+scalar @$merged_fids, $fi->eval_line, $fi->eval_fi->filename;
},
);
@@ -348,6 +349,7 @@
$reporter->set_param(mk_report_source_line => \&mk_report_source_line);
$reporter->set_param(mk_report_xsub_line => \&mk_report_xsub_line );
+$reporter->set_param(mk_report_separator_line =>
\&mk_report_separator_line );
sub mk_report_source_line {
my ($linenum, $line, $stats_for_line, $stats_for_file, $profile, $fi)
= @_;
@@ -378,6 +380,15 @@
"</tr>\n";
}
+sub mk_report_separator_line {
+ my ($profile, $fi) = @_;
+ return join "",
+ sprintf(qq{<tr><td class="s"><a
name="%s"></a>%s</td>}, '', ' '),
+ "<td></td><td></td><td></td><td></td>",
+ '<td class="s"></td>',
+ "</tr>\n";
+}
+
sub _escape_html {
local $_ = shift;
@@ -1402,6 +1413,8 @@
my $title = shift || "Profile Index - NYTProf";
my $opts = shift || {};
+ $title = _escape_html($title);
+
my $html = <<EOD;
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0
Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd";>
<html xmlns="http://www.w3.org/1999/xhtml";>
=======================================
--- /trunk/lib/Devel/NYTProf/Data.pm Wed Apr 21 04:38:30 2010
+++ /trunk/lib/Devel/NYTProf/Data.pm Wed Apr 21 06:25:45 2010
@@ -123,31 +123,58 @@
sub collapse_evals_in {
my ($profile, $parent_fi) = @_;
-
- my %eval_places;
+ my $parent_fid = $parent_fi->fid;
+
+ my %evals_on_line;
for my $fi ($parent_fi->has_evals) {
$profile->collapse_evals_in($fi); # recurse first
- push @{ $eval_places{$fi->eval_fid}->{$fi->eval_line} }, $fi;
- }
- while ( my ($fid, $line2fis) = each %eval_places) {
- while ( my ($line, $siblings) = each %$line2fis) {
-
- next if @$siblings == 1;
-
- my @subs = map { values %{ $_->subs } } @$siblings;
- my @calls = map { keys %{ $_->sub_call_lines } } @$siblings;
- my @evals = map { $_->has_evals(0) } @$siblings;
- my $msg = sprintf "%d:%d: multiple evals (subs %d, calls %d,
evals %d, fids: %s)",
- $fid, $line, scalar @subs, scalar @calls, scalar
@evals,
- join(", ", map { $_->fid } @$siblings);
- warn "$msg\n" if $trace >= 3;
-
- next if @subs; # ignore if the eval defines subs
- next if @evals; # ignore if the eval has nested evals
-
- warn "$msg COLLAPSING\n" if $trace >= 0;
- my $parent = $siblings->[0]->eval_fi;
- $parent->collapse_sibling_evals(@$siblings);
+ push @{ $evals_on_line{$fi->eval_line} }, $fi;
+ }
+ while ( my ($line, $siblings) = each %evals_on_line) {
+
+ next if @$siblings == 1;
+
+ my @subs = map { values %{ $_->subs } } @$siblings;
+ my @calls = map { keys %{ $_->sub_call_lines } } @$siblings;
+ my @evals = map { $_->has_evals(0) } @$siblings;
+ my $msg = sprintf "%d:%d: multiple evals (subs %d, calls %d,
evals %d, fids: %s)",
+ $parent_fid, $line, scalar @subs, scalar @calls, scalar
@evals,
+ join(", ", map { $_->fid } @$siblings);
+ warn "$msg\n" if $trace >= 3;
+
+ next if @subs; # ignore if the eval defines subs
+ next if @evals; # ignore if the eval has nested evals
+
+ # compare src code of evals and collapse identical ones
+ my %src_same;
+ for my $fi (@$siblings) {
+ my $srclines_array = $fi->srclines_array || [];
+ my $src = join "\n", @$srclines_array;
+ my $key = join ",", # XXX just a basic key
+ scalar @$srclines_array, # number of lines
+ length $src, # total length
+ unpack("%32C*",$src); # 32-bit checksum
+ push @{$src_same{$key}}, $fi;
+ }
+
+ warn sprintf "%s COLLAPSING (%d distinct src)\n",
+ $msg, scalar keys %src_same
+ if $trace >= 0;
+
+ # if not 'too many' distinct eval source strings then collapse
+ # the evals for each distinct source string
+ if (values %src_same < 100) {
+
+ for my $src_same_fis (values %src_same) {
+ next if @$src_same_fis == 1; # unique src code
+ warn "Collapsing identical evals: @{[ map { $_->fid }
@$src_same_fis ]}\n"
+ if $trace >= 0;
+ my $fi =
$parent_fi->collapse_sibling_evals(@$src_same_fis);
+ @$src_same_fis = ( $fi ); # update list in-place
+ }
+ }
+ else {
+ $parent_fi->collapse_sibling_evals(@$siblings);
}
}
}
@@ -729,7 +756,8 @@
my $fileinfo = $fid && $self->fileinfo_of($fid)
or die "No fid_fileinfo for sub $sub fid '$fid'\n";
while ($fileinfo->eval_fid) {
-carp "file_line_range_of_sub($sub) called for sub defined in eval"; # XXX
+warn "file_line_range_of_sub($sub) called for sub defined in eval\n"; # XXX
+last;
# eg string eval
# eg [ "(eval 6)[/usr/local/perl58-i/lib/5.8.6/Benchmark.pm:634]",
2, 634 ]
warn sprintf "file_line_range_of_sub: %s: fid %d -> %d for %s\n",
=======================================
--- /trunk/lib/Devel/NYTProf/FileInfo.pm Wed Apr 21 04:41:03 2010
+++ /trunk/lib/Devel/NYTProf/FileInfo.pm Wed Apr 21 06:25:45 2010
@@ -315,6 +315,7 @@
$self->_delete_eval($donor_fi);
$donor_fi->_nullify;
}
+ return $survivor;
}
=======================================
--- /trunk/lib/Devel/NYTProf/Reader.pm Mon Apr 19 04:08:57 2010
+++ /trunk/lib/Devel/NYTProf/Reader.pm Wed Apr 21 06:25:45 2010
@@ -59,6 +59,7 @@
datastart => '',
mk_report_source_line => undef,
mk_report_xsub_line => undef,
+ mk_report_separator_line => undef,
line => [
{},
{value => 'time', end => ',', default => '0'},
@@ -377,9 +378,11 @@
chomp $line;
# detect a series of blank lines, e.g. a chunk of pod savesrc
didn't store
- my $skip_blanks = ($prev_line eq '' && $line eq '' &&
@$src_lines && $src_lines->[0] =~ /^\s*$/);
-
- #warn "$LINE: ".join(" ", $prev_line eq '', $line eq '',
$src_lines->[0] =~ /^\s*$/)."\n";
+ my $skip_blanks = (
+ $prev_line eq '' && $line eq '' && # blank
behind and here
+ @$src_lines && $src_lines->[0] =~ /^\s*$/ && # blank ahead
+ !$stats_by_line{$LINE} # nothing to
report
+ );
if ($line =~ m/^\# \s* line \s+ (\d+) \b/x) {
# XXX we should be smarter about this - patches welcome!
@@ -396,9 +399,12 @@
$profile,
$fi,
);
-
+
if ($skip_blanks) {
- while (@$src_lines and $src_lines->[0] =~ /^\s*$/) {
+ while (
+ @$src_lines && $src_lines->[0] =~ /^\s*$/ &&
+ !$stats_by_line{$LINE+1}
+ ) {
shift @$src_lines;
$LINE++;
}
@@ -408,6 +414,10 @@
continue {
$LINE++;
}
+
+ if (my $line_sub = $self->{mk_report_separator_line}) {
+ print OUT $line_sub->($profile, $fi);
+ }
# iterate over xsubs
$line_sub = $self->{mk_report_xsub_line}
@@ -415,11 +425,18 @@
my $subs_defined_in_file =
$profile->subs_defined_in_file($filestr, 0);
foreach my $subname (sort keys %$subs_defined_in_file) {
my $subinfo = $subs_defined_in_file->{$subname};
- next unless $subinfo->is_xsub;
-
- my $src = "sub $subname; # xsub\n\t";
-
- print OUT $line_sub->($subname, $src, undef, undef, [ $subinfo
], {}, $profile, '');
+ my $kind = $subinfo->kind;
+
+ next if $kind eq 'perl';
+ next if $subinfo->calls == 0;
+
+ print OUT $line_sub->(
+ $subname,
+ "sub $subname; # $kind\n\t",
+ { subdef_info => [ $subinfo ], }, #stats_for_line
+ undef, # stats_for_file
+ $profile, $fi
+ );
}
print OUT $dataend;
=======================================
--- /trunk/lib/Devel/NYTProf/SubInfo.pm Wed Apr 21 04:38:30 2010
+++ /trunk/lib/Devel/NYTProf/SubInfo.pm Wed Apr 21 06:25:45 2010
@@ -79,11 +79,26 @@
my $self = shift;
# XXX should test == 0 but some xsubs still have undef first_line etc
+ # XXX shouldn't include opcode
my $first = $self->first_line;
return undef if not defined $first;
return 1 if $first == 0 && $self->last_line == 0;
return 0;
}
+
+sub is_opcode {
+ my $self = shift;
+ return 0 if $self->first_line or $self->last_line;
+ return 1 if $self->subname =~ m/(?:^CORE::|::CORE:)\w+$/;
+ return 0;
+}
+
+sub kind {
+ my $self = shift;
+ return 'opcode' if $self->is_opcode;
+ return 'xsub' if $self->is_xsub;
+ return 'perl';
+}
sub fileinfo {
my $self = shift;
--
You've received this message because you are subscribed to
the Devel::NYTProf Development User group.
Group hosted at: http://groups.google.com/group/develnytprof-dev
Project hosted at: http://perl-devel-nytprof.googlecode.com
CPAN distribution: http://search.cpan.org/dist/Devel-NYTProf
To post, email: [email protected]
To unsubscribe, email: [email protected]
