Revision: 1264
Author: [email protected]
Date: Tue Jun 1 13:59:18 2010
Log: Allow collapse of sibling evals that have sub definitions (will only
happen
within a group that has identical src_digest which means the src really is
identical, in which case the src of the subs will also be, or there's no src
code, in which case we don't mind merging subs because the report for that
fid
will be fairly useless anyway).
What's missing now is renaming of ANON subs.
All this stuff is way too painful :(
http://code.google.com/p/perl-devel-nytprof/source/detail?r=1264
Modified:
/trunk/lib/Devel/NYTProf/Data.pm
/trunk/lib/Devel/NYTProf/FileInfo.pm
/trunk/lib/Devel/NYTProf/SubInfo.pm
=======================================
--- /trunk/lib/Devel/NYTProf/Data.pm Sun May 30 01:30:17 2010
+++ /trunk/lib/Devel/NYTProf/Data.pm Tue Jun 1 13:59:18 2010
@@ -147,9 +147,10 @@
my %src_keyed;
for my $fi (@$siblings) {
my $key = $fi->src_digest;
- # include extra info to segregate (especially when there's no
src)
- $key .= ',evals' if $fi->has_evals;
- $key .= ',subs' if $fi->subs_defined;
+ if (!$key) { # include extra info to segregate when there's no
src
+ $key .= ',evals' if $fi->has_evals;
+ $key .= ',subs' if $fi->subs_defined;
+ }
push @{$src_keyed{$key}}, $fi;
}
@@ -169,17 +170,14 @@
$parent_fi->collapse_sibling_evals(@$siblings);
}
else {
- # finnese: consider each distinct src in turn
+ # finesse: consider each distinct src in turn
while ( my ($key, $src_same_fis) = each %src_keyed ) {
next if @$src_same_fis == 1; # unique src key
my @fids = map { $_->fid } @$src_same_fis;
- if (grep { $_->subs_defined } @$src_same_fis) {
- warn "evals($key): collapsing skipped due to subs:
@fids\n" if $trace >= 3;
- }
- elsif (grep { $_->has_evals(0) } @$src_same_fis) {
- warn "evals($key): collapsing skipped due to evals:
@fids\n" if $trace >= 3;
+ if (grep { $_->has_evals(0) } @$src_same_fis) {
+ warn "evals($key): collapsing skipped due to evals in
@fids\n" if $trace >= 3;
}
else {
warn "evals($key): collapsing identical: @fids\n" if
$trace >= 3;
@@ -703,7 +701,7 @@
return if not $fid; # sub has no known file
my $fileinfo = $fid && $self->fileinfo_of($fid)
- or die "No fid_fileinfo for sub $sub fid '$fid'\n";
+ or croak "No fid_fileinfo for sub $sub fid '$fid'";
return ($fileinfo->filename, $fid, $first, $last, $fileinfo);
}
=======================================
--- /trunk/lib/Devel/NYTProf/FileInfo.pm Sun May 30 01:17:44 2010
+++ /trunk/lib/Devel/NYTProf/FileInfo.pm Tue Jun 1 13:59:18 2010
@@ -112,7 +112,17 @@
sub _add_new_sub_defined {
my ($self, $subinfo) = @_;
- $self->[NYTP_FIDi_SUBS_DEFINED()]->{$subinfo->subname} = $subinfo
+ my $subs_defined = $self->[NYTP_FIDi_SUBS_DEFINED()];
+ if (my $existing_si = $subs_defined->{$subinfo->subname}) {
+ warn sprintf "Merging %s sub into existing sub with same name
in %s\n",
+ $subinfo->subname, $self->filename;
+ $existing_si->merge_in($subinfo);
+ @$subinfo = (); # zap!
+ }
+ else {
+ $subs_defined->{$subinfo->subname} = $subinfo;
+ }
+
}
@@ -276,12 +286,23 @@
# copy data from donor to survivor then delete donor
# XXX nested evals not handled yet
- warn "collapse_sibling_evals: nested evals not handled"
+ warn sprintf "collapse_sibling_evals: nested evals in %s not
handled",
+ $donor_fi->filename
if $donor_fi->has_evals;
- # XXX subs defined not handled yet
- warn "collapse_sibling_evals: subs defined not handled"
- if $donor_fi->subs_defined;
+ if (my @subs_defined = $donor_fi->subs_defined) {
+ warn "collapse_sibling_evals: subs defined not fully handled"
+ if $trace;
+
+ for my $si (@subs_defined) {
+ warn sprintf "Moving fid %d sub %s\n",
+ $donor_fi->fid, $si->subname
+ if $trace;
+ $donor_fi->_remove_sub_defined($si);
+ $survivor->_add_new_sub_defined($si);
+ $si->_move_to_fileinfo($survivor);
+ }
+ }
# '1' => { 'main::foo' => [ 1, '1.38e-05', '1.24e-05', ...,
{ 'main::RUNTIME' => undef } ] }
if (my $sub_call_lines = $donor_fi->sub_call_lines) {
@@ -402,12 +423,12 @@
return $self->cache->{src_digest} ||= do {
my $srclines_array = $self->srclines_array || [];
my $src = join "\n", @$srclines_array;
- my @key = (
- scalar @$srclines_array, # number of lines
- length $src, # total length
- unpack("%32C*",$src), # 32-bit checksum
- );
- join ",", @key;
+ # return empty string for digest if there's no src
+ ($src) ? join ",", (
+ scalar @$srclines_array, # number of lines
+ length $src, # total length
+ unpack("%32C*",$src) ) # 32-bit checksum
+ : '';
};
}
=======================================
--- /trunk/lib/Devel/NYTProf/SubInfo.pm Tue Jun 1 04:28:28 2010
+++ /trunk/lib/Devel/NYTProf/SubInfo.pm Tue Jun 1 13:59:18 2010
@@ -111,6 +111,11 @@
}
$self->profile->fileinfo_of($fid);
}
+
+sub _move_to_fileinfo {
+ my ($self, $fi) = @_;
+ $self->[NYTP_SIi_FID] = $fi->fid;
+}
sub clone { # shallow
my $self = shift;
@@ -172,6 +177,24 @@
$new_fi->_add_new_sub_defined($self);
}
}
+
+
+sub _rename {
+ my ($self, $newname) = @_;
+
+ my $oldname = $self->[NYTP_SIi_SUB_NAME];
+ return if $newname eq $oldname;
+
+ $self->[NYTP_SIi_SUB_NAME] = $newname;
+
+ $self->fileinfo->_rename_subinfo($self, $newname);
+
+ my $callers = $self->caller_fid_line_places || {};
+ for my $sc (map { values %$_ } values %$callers) {
+ my $caller_subnames = $sc->[NYTP_SCi_CALLING_SUB];
+ }
+
+}
# merge details of another sub into this one
@@ -184,15 +207,17 @@
# see also "case NYTP_TAG_SUB_CALLERS:" in
load_profile_data_from_stream()
+ if ($new->[NYTP_SIi_SUB_NAME] ne $self->[NYTP_SIi_SUB_NAME]) {
+ $self->[NYTP_SIi_SUB_NAME] = [ $self->[NYTP_SIi_SUB_NAME] ]
+ if not ref $self->[NYTP_SIi_SUB_NAME];
+ push @{$self->[NYTP_SIi_SUB_NAME]}, $new->[NYTP_SIi_SUB_NAME];
+ }
+
$self->[NYTP_SIi_FIRST_LINE] = _min($self->[NYTP_SIi_FIRST_LINE],
$new->[NYTP_SIi_FIRST_LINE]);
$self->[NYTP_SIi_LAST_LINE] = _max($self->[NYTP_SIi_LAST_LINE],
$new->[NYTP_SIi_LAST_LINE]);
-
$self->[NYTP_SIi_CALL_COUNT] += $new->[NYTP_SIi_CALL_COUNT];
$self->[NYTP_SIi_INCL_RTIME] += $new->[NYTP_SIi_INCL_RTIME];
$self->[NYTP_SIi_EXCL_RTIME] += $new->[NYTP_SIi_EXCL_RTIME];
- $self->[NYTP_SIi_SUB_NAME] = [ $self->[NYTP_SIi_SUB_NAME] ]
- if not ref $self->[NYTP_SIi_SUB_NAME];
- push @{$self->[NYTP_SIi_SUB_NAME]}, $new->[NYTP_SIi_SUB_NAME];
$self->[NYTP_SIi_REC_DEPTH] = max($self->[NYTP_SIi_REC_DEPTH],
$new->[NYTP_SIi_REC_DEPTH]);
# adding reci_rtime is correct only if one sub doesn't call the other
$self->[NYTP_SIi_RECI_RTIME] += $new->[NYTP_SIi_RECI_RTIME]; # XXX
--
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]
