Revision: 1278
Author: [email protected]
Date: Mon Jun 7 08:07:31 2010
Log: Finally escaped the eval/anon merging tar-pit by giving subinfo and
fileinfo
their own copies of the subcallinfo data instead of sharing the same one!
That's a tiny change in NYTProf.xs. The rest of this is collateral hacking.
http://code.google.com/p/perl-devel-nytprof/source/detail?r=1278
Added:
/trunk/lib/Devel/NYTProf/SubCallInfo.pm
Modified:
/trunk/Changes
/trunk/NYTProf.xs
/trunk/lib/Devel/NYTProf/Data.pm
/trunk/lib/Devel/NYTProf/FileInfo.pm
/trunk/lib/Devel/NYTProf/SubInfo.pm
=======================================
--- /dev/null
+++ /trunk/lib/Devel/NYTProf/SubCallInfo.pm Mon Jun 7 08:07:31 2010
@@ -0,0 +1,26 @@
+package Devel::NYTProf::SubCallInfo;
+
+use strict;
+use warnings;
+use Carp;
+
+use Devel::NYTProf::Constants qw(
+ NYTP_SCi_CALL_COUNT
+ NYTP_SCi_INCL_RTIME NYTP_SCi_EXCL_RTIME NYTP_SCi_RECI_RTIME
+ NYTP_SCi_REC_DEPTH NYTP_SCi_CALLING_SUB
+ NYTP_SCi_elements
+);
+
+sub calls { shift->[NYTP_SCi_CALL_COUNT] }
+
+sub incl_time { shift->[NYTP_SCi_INCL_RTIME] }
+
+sub excl_time { shift->[NYTP_SCi_EXCL_RTIME] }
+
+sub recur_max_depth { shift->[NYTP_SCi_REC_DEPTH] }
+
+sub recur_incl_time { shift->[NYTP_SCi_RECI_RTIME] }
+
+
+# vim:ts=8:sw=4:et
+1;
=======================================
--- /trunk/Changes Sat Jun 5 15:31:30 2010
+++ /trunk/Changes Mon Jun 7 08:07:31 2010
@@ -23,6 +23,7 @@
* report totals (evals and subs) should account for things merged away
eg perhaps add $si->subs_defined_count() that includes count of merged
subs
* resolve undef warnings from nytprofhtml on (eg) perlcritic of perlcritic
+* document anon sub merging
Major changes:
=======================================
--- /trunk/NYTProf.xs Mon Jun 7 07:10:32 2010
+++ /trunk/NYTProf.xs Mon Jun 7 08:07:31 2010
@@ -3993,7 +3993,9 @@
subinfo_av = lookup_subinfo_av(aTHX_ called_subname_sv,
state->sub_subinfo_hv);
- /* { caller_fid => { caller_line => [ count, incl_time, ... ] } } */
+ /* subinfo_av's NYTP_SIi_CALLED_BY element is a hash ref:
+ * { caller_fid => { caller_line => [ count, incl_time, ... ] } }
+ */
sv = *av_fetch(subinfo_av, NYTP_SIi_CALLED_BY, 1);
if (!SvROK(sv)) /* autoviv */
sv_setsv(sv, newRV_noinc((SV*)newHV()));
@@ -4020,6 +4022,7 @@
*/
logwarn("Merging extra sub caller info for %s called
at %d:%d\n",
SvPV_nolen(called_subname_sv), fid, line);
+
av = (AV *)SvRV(sv);
sv = *av_fetch(av, NYTP_SCi_CALL_COUNT, 1);
sv_setuv(sv, (SvOK(sv)) ? SvUV(sv) + count : count);
@@ -4036,21 +4039,25 @@
sv = *av_fetch(av, NYTP_SCi_REC_DEPTH, 1);
if (!SvOK(sv) || SvUV(sv) < rec_depth) /* max() */
sv_setuv(sv, rec_depth);
-
/* XXX temp hack way to store calling subname */
sv = *av_fetch(av, NYTP_SCi_CALLING_SUB, 1);
if (!SvROK(sv)) /* autoviv */
sv_setsv(sv, newRV_noinc((SV*)newHV()));
(void)hv_fetch_ent((HV *)SvRV(sv), caller_subname_sv, 1, 0);
- /* add sub call to NYTP_FIDi_SUBS_CALLED hash of fid making the
call */
- /* => { line => { subname => [ ... ] } } */
+ /* also reference this sub call info array from the calling
fileinfo
+ * fi->[NYTP_FIDi_SUBS_CALLED] => { line => { subname => [ ... ] }
}
+ */
fi = SvRV(*av_fetch(state->fid_fileinfo_av, fid, 1));
fi = *av_fetch((AV *)fi, NYTP_FIDi_SUBS_CALLED, 1);
fi = *hv_fetch((HV*)SvRV(fi), text, len, 1);
if (!SvROK(fi)) /* autoviv */
sv_setsv(fi, newRV_noinc((SV*)newHV()));
fi = HeVAL(hv_fetch_ent((HV *)SvRV(fi), called_subname_sv, 1, 0));
+ if (1) { /* ref a clone of the sub call info array */
+ AV *av2 = av_make(AvFILL(av)+1, AvARRAY(av));
+ av = av2;
+ }
sv_setsv(fi, newRV_inc((SV *)av));
}
else { /* is meta-data about sub */
=======================================
--- /trunk/lib/Devel/NYTProf/Data.pm Mon Jun 7 07:15:27 2010
+++ /trunk/lib/Devel/NYTProf/Data.pm Mon Jun 7 08:07:31 2010
@@ -141,6 +141,7 @@
$profile->collapse_evals_in($fi); # recurse first
push @{ $evals_on_line{$fi->eval_line} }, $fi;
}
+
while ( my ($line, $siblings) = each %evals_on_line) {
next if @$siblings == 1;
@@ -164,6 +165,16 @@
scalar keys %src_keyed,
$parent_fi->filename,
join(" ", map { $_->fid } @$siblings);
+ if (trace_level() >= 2) {
+ for my $si (@subs) {
+ warn sprintf "%d:%d evals: define sub %s in fid %s\n",
+ $parent_fid, $line, $si->subname, $si->fid;
+ }
+ for my $fi (@evals) {
+ warn sprintf "%d:%d evals: execute eval %s\n",
+ $parent_fid, $line, $fi->filename;
+ }
+ }
}
# if 'too many' distinct eval source keys then simply collapse all
@@ -246,7 +257,8 @@
for my $subinfos (values %to_merge) {
my $subinfo = shift(@$subinfos)->clone;
- $subinfo->merge_in($_) for @$subinfos;
+ $subinfo->merge_in($_, src_keep => 1)
+ for @$subinfos;
# replace the many with the one
@$subinfos = ($subinfo);
}
=======================================
--- /trunk/lib/Devel/NYTProf/FileInfo.pm Mon Jun 7 07:15:27 2010
+++ /trunk/lib/Devel/NYTProf/FileInfo.pm Mon Jun 7 08:07:31 2010
@@ -17,6 +17,7 @@
NYTP_SCi_CALL_COUNT NYTP_SCi_INCL_RTIME NYTP_SCi_EXCL_RTIME
NYTP_SCi_RECI_RTIME
NYTP_SCi_REC_DEPTH NYTP_SCi_CALLING_SUB
+ NYTP_SCi_elements
);
# extra constants for private elements
@@ -268,6 +269,7 @@
for my $donor_fi (@donors) {
# copy data from donor to survivor_fi then delete donor
+
warn sprintf "collapse_sibling_evals: processing donor
fid %d: %s\n",
$donor_fi->fid, $donor_fi->filename
if trace_level();
@@ -277,6 +279,8 @@
$donor_fi->filename
if $donor_fi->has_evals;
+ # for each sub defined in the donor,
+ # move the sub definition to the survivor
if (my @subs_defined = $donor_fi->subs_defined) {
for my $si (@subs_defined) {
@@ -289,6 +293,8 @@
}
}
+ # for each sub call made by the donor,
+ # move the sub calls to the survivor
# 1 => { 'main::foo' => [ 1, '1.38e-05', '1.24e-05', ...,
{ 'main::RUNTIME' => undef } ] }
if (my $sub_call_lines = $donor_fi->sub_call_lines) {
@@ -299,17 +305,19 @@
my $s_sc_hash = $s_scl->{$line} ||= {};
for my $subname (keys %$sc_hash ) {
my $s_sc_info = $s_sc_hash->{$subname} ||= [];
-
-
Devel::NYTProf::SubInfo::_merge_in_caller_info($s_sc_info, delete
$sc_hash->{$subname}, "eval"); # XXX
+ my $sc_info = delete $sc_hash->{$subname};
+
Devel::NYTProf::SubInfo::_merge_in_caller_info($s_sc_info, $sc_info,
+ tag => "line $line calls to $subname",
+ );
+
$subnames_called_by_donor{$subname}++;
}
}
%$sub_call_lines = (); # zap
- # update subinfo
+ # update subinfo (NYTP_SIi_CALLED_BY)
$profile->subinfo_of($_)->_alter_called_by_fileinfo($donor_fi,
$survivor_fi)
for keys %subnames_called_by_donor;
-
}
# copy line time data
@@ -337,11 +345,13 @@
$donor_fi->_nullify;
}
+ # now the fid merging is complete...
# look for any anon subs that are effectively duplicates
# (ie have the same name except for eval seqn)
# if more than one for any given name we merge them
if (my @subs_defined = $survivor_fi->subs_defined_sorted) {
- # bucket by normalized name
+
+ # bucket anon subs by normalized name
my %newname;
for my $si (@subs_defined) {
next unless $si->is_anon;
@@ -370,12 +380,10 @@
for my $subs_called_on_line (values %{
$caller_fi->sub_call_lines }) {
my $sc_info = delete
$subs_called_on_line->{$delete_subname}
or next;
- if (my $s_sc_info =
$subs_called_on_line->{$survivor_subname}) {
-
Devel::NYTProf::SubInfo::_merge_in_caller_info($s_sc_info, $sc_info); # XXX
- }
- else {
- $subs_called_on_line->{$survivor_subname} =
$sc_info;
- }
+ my $s_sc_info =
$subs_called_on_line->{$survivor_subname} ||= [];
+
Devel::NYTProf::SubInfo::_merge_in_caller_info($s_sc_info, $sc_info,
+ tag => "collapse eval $delete_subname",
+ );
}
}
=======================================
--- /trunk/lib/Devel/NYTProf/SubInfo.pm Mon Jun 7 07:15:27 2010
+++ /trunk/lib/Devel/NYTProf/SubInfo.pm Mon Jun 7 08:07:31 2010
@@ -183,21 +183,20 @@
my $cb = delete $called_by->{$remove_fid};
if ($cb && $new_fid) {
-
- warn sprintf "Altering %s to change calls from fid %d to be
from fid %d\n",
+ my $new_cb = $called_by->{$new_fid} ||= {};
+
+ warn sprintf "_alter_called_by_fileinfo: %s from fid %d to
fid %d\n",
$self->subname, $remove_fid, $new_fid
if trace_level();
- if (my $new_cb = $called_by->{$new_fid}) {
- # need to merge $cb into $new_cb
- while ( my ($line, $cb_li) = each %$cb ) {
- my $dst_line_info = $new_cb->{$line} ||= [];
- _merge_in_caller_info($dst_line_info, delete
$cb->{$line}, $self->subname);
- }
- }
- else {
- $called_by->{$new_fid} = $cb;
- }
+ # merge $cb into $new_cb
+ while ( my ($line, $cb_li) = each %$cb ) {
+ my $dst_line_info = $new_cb->{$line} ||= [];
+ _merge_in_caller_info($dst_line_info, delete $cb->{$line},
+ tag => "$line:".$self->subname,
+ );
+ }
+
}
}
@@ -235,16 +234,19 @@
my $dst_called_by = $self ->[NYTP_SIi_CALLED_BY] ||= {};
my $src_called_by = $donor->[NYTP_SIi_CALLED_BY] || {};
+ $opts{opts} ||= "merge in $donor_subname";
+
# iterate over src and merge into dst
while (my ($fid, $src_line_hash) = each %$src_called_by) {
my $dst_line_hash = $dst_called_by->{$fid};
- #if (!$dst_line_hash) { $dst_called_by->{$fid} = $src_line_hash;
next; }
# merge lines in %$src_line_hash into %$dst_line_hash
for my $line (keys %$src_line_hash) {
my $dst_line_info = $dst_line_hash->{$line} ||= [];
- _merge_in_caller_info($dst_line_info, delete
$src_line_hash->{$line}, "merge in $donor_subname");
+ my $src_line_info = $src_line_hash->{$line};
+ delete $src_line_hash->{$line} unless $opts{src_keep};
+ _merge_in_caller_info($dst_line_info, $src_line_info, %opts);
}
}
@@ -253,24 +255,24 @@
sub _merge_in_caller_info {
- my ($dst_line_info, $src_line_info, $tag) = @_;
- $tag = ($tag) ? " $tag" : "";
+ my ($dst_line_info, $src_line_info, %opts) = @_;
+ my $tag = ($opts{tag}) ? " $opts{tag}" : "";
if (!...@$src_line_info) {
carp sprintf "_merge_in_caller_info%s skipped (empty donor)", $tag
if trace_level();
return;
}
- if (!...@$dst_line_info) {
- @$dst_line_info = (0) x NYTP_SCi_elements;
- $dst_line_info->[NYTP_SCi_CALLING_SUB] = undef;
- }
if (trace_level()) {
- carp sprintf "_merge_in_caller_info%s merging:", $tag;
+ carp sprintf "_merge_in_caller_info%s merging from $src_line_info
-> $dst_line_info:", $tag;
warn sprintf " . %s\n", fmt_sc($src_line_info);
warn sprintf " + %s\n", fmt_sc($dst_line_info);
}
+ if (!...@$dst_line_info) {
+ @$dst_line_info = (0) x NYTP_SCi_elements;
+ $dst_line_info->[NYTP_SCi_CALLING_SUB] = undef;
+ }
# merge @$src_line_info into @$dst_line_info
$dst_line_info->[$_] += $src_line_info->[$_] for (
@@ -289,13 +291,12 @@
warn sprintf " = %s\n", fmt_sc($dst_line_info)
if trace_level();
- @$src_line_info = (); # zap!
-
return;
}
sub fmt_sc {
my ($sc) = @_;
+ return "(empty)" if !...@$sc;
my $dst_cs = $sc->[NYTP_SCi_CALLING_SUB]||{};
my $by = join " & ", sort keys %$dst_cs;
sprintf "calls %d%s",
--
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]
