Author: tim.bunce
Date: Tue Oct 21 15:51:10 2008
New Revision: 530
Added:
trunk/t/test20-streval.p
trunk/t/test20-streval.rdt
Modified:
trunk/Changes
trunk/MANIFEST
trunk/lib/Devel/NYTProf/Data.pm
trunk/t/test09.rdt
trunk/t/test13.rdt
Log:
Add migration of sub_caller data from eval fids. (big missing feature)
Consolidate caches and provide a method to access and clear them.
Add method to return hash of eval fid to base fid mapping.
Add method to return hash of subs called by a fid.
Add method to delete data of subs called by a fid.
Modified: trunk/Changes
==============================================================================
--- trunk/Changes (original)
+++ trunk/Changes Tue Oct 21 15:51:10 2008
@@ -11,6 +11,10 @@
Now builds on Windows, with thanks to Jan Dubois!
+ Subroutine calls made from within string evals (and even
+ string evals within string evals etc) are now shown
+ in reports.
+
XS subs (xsubs) are now automatically associated with a source
file that defines normal subs in the same package.
Callers and timing information for xsubs are now shown at the
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Tue Oct 21 15:51:10 2008
@@ -75,6 +75,8 @@
t/test16.p
t/test16.rdt
t/test16.x
+t/test20-streval.p
+t/test20-streval.rdt
t/test30-fork.0.p
t/test30-fork.0.rdt
t/test30-fork.0.x
Modified: trunk/lib/Devel/NYTProf/Data.pm
==============================================================================
--- trunk/lib/Devel/NYTProf/Data.pm (original)
+++ trunk/lib/Devel/NYTProf/Data.pm Tue Oct 21 15:51:10 2008
@@ -91,6 +91,43 @@
(my $sub_class = $class) =~ s/\w+$/ProfSub/;
$_ and bless $_ => $sub_class for values %$sub_subinfo;
+
+ # migrate sub calls made from evals to be calls from the base fid
+ #
+ # map of { eval_fid => base_fid, ... }
+ my $eval_fid_map = $profile->eval_fid_map;
+ # map of { fid => { subs called from fid... }, ... }
+ my $fid_sub_calls_map = $profile->fid_sub_calls_map;
+ #
+ while ( my ($eval_fid, $base_fid) = each %$eval_fid_map ) {
+ my $subnames = $fid_sub_calls_map->{$eval_fid}
+ or next; # no subs called from this eval fid
+
+ # drill thru string-evals-within-string-evals
+ $base_fid = $eval_fid_map->{$base_fid}
+ while $eval_fid_map->{$base_fid};
+
+ my $line_of_eval = $profile->fileinfo_of($eval_fid)->eval_line;
+ warn "Migrating sub calls from eval fid $eval_fid to fid $base_fid
line $line_of_eval: @$subnames\n"
+ if $trace;
+
+ my $sub_caller = $profile->{sub_caller};
+ for my $subname (@$subnames) {
+
+ my $eval_calls = delete $sub_caller->{$subname}{$eval_fid}
+ or die "panic";
+ my $base_calls = $sub_caller->{$subname}{$base_fid} ||=
{};
+
+ warn "merged $subname calls from fid $eval_fid to $base_fid\n";
+ while ( my ($line_in_eval, $eval_line_calls) =
each %$eval_calls ) {
+ my $e = $eval_calls->{$line_in_eval};
+ my $b = $base_calls->{$line_of_eval} ||= [ (0) x @$e ];
+ $b->[$_] += $e->[$_] for ([EMAIL PROTECTED]);
+ }
+ }
+ }
+ $profile->_clear_caches;
+
# XXX merge evals - should become a method optionally called here
# (which uses other methods to do the work and those methods
# should also be called by Devel::NYTProf::ProfSub::callers())
@@ -153,10 +190,14 @@
}
}
}
+ $profile->_clear_caches;
return $profile;
}
+sub _caches { return shift->{caches} ||= {} }
+sub _clear_caches { return delete shift->{caches} }
+
sub all_subinfos {
my @all = values %{ shift->{sub_subinfo} };
return @all;
@@ -188,6 +229,30 @@
return $self->{fid_fileinfo}[$fid];
}
+sub eval_fid_map {
+ my $self = shift;
+ my $fid_fileinfo = $self->{fid_fileinfo} || [];
+ my $eval_fid_map = {};
+ for my $fileinfo (@$fid_fileinfo) {
+ my $base_fid = $fileinfo && $fileinfo->eval_fid
+ or next;
+ $eval_fid_map->{ $fileinfo->fid } = $base_fid;
+ }
+ return $eval_fid_map;
+}
+
+sub fid_sub_calls_map {
+ my $self = shift;
+ my $sub_caller = $self->{sub_caller} || {};
+ my $fid_sub_calls_map = {};
+ while ( my ($subname, $fid_hash) = each %$sub_caller ) {
+ for my $fid (keys %$fid_hash) {
+ push @{ $fid_sub_calls_map->{$fid} }, $subname;
+ }
+ }
+ return $fid_sub_calls_map;
+}
+
sub inc {
@@ -291,6 +356,7 @@
my $filehandle = $args->{filehandle} || \*STDOUT;
my $startnode = $args->{startnode} || $self; # undocumented
croak "Invalid startnode" unless ref $startnode;
+ $self->_clear_caches;
_dump_elements($startnode, $separator, $filehandle, []);
}
@@ -401,10 +467,7 @@
}
}
- # remove sub_caller info for calls made from within this file
- if (my $sub_caller = $self->{sub_caller}) {
- delete $_->{$fid} for values %$sub_caller;
- }
+ $fileinfo->delete_subs_called_info;
}
@@ -532,7 +595,8 @@
sub _filename_to_fid {
my $self = shift;
- return $self->{_filename_to_fid_cache} ||= do {
+ my $caches = $self->_caches;
+ return $caches->{_filename_to_fid_cache} ||= do {
my $fid_fileinfo = $self->{fid_fileinfo} || [];
my $filename_to_fid = {};
for my $fid (1 .. @$fid_fileinfo - 1) {
@@ -552,7 +616,7 @@
in a source file. The $file argument can be an integer file id (fid) or a
file
path. If $file is 0 then details for all known subroutines are returned.
-Returns undef if the profile contains no C<sub_caller> data for the $file.
+Returns undef if the profile contains no C<sub_subinfo> data for the $file.
The keys of the returned hash are fully qualified subroutine names and the
corresponding value is a hash reference containing
L<Devel::NYTProf::ProfSub>
@@ -565,15 +629,15 @@
=cut
-
sub subs_defined_in_file {
my ($self, $fid, $incl_lines) = @_;
$fid = $self->resolve_fid($fid);
$incl_lines ||= 0;
$incl_lines = 0 if $fid == 0;
+ my $caches = $self->_caches;
my $cache_key = "_cache:subs_defined_in_file:$fid:$incl_lines";
- return $self->{$cache_key} if $self->{$cache_key};
+ return $caches->{$cache_key} if $caches->{$cache_key};
my $sub_subinfo = $self->{sub_subinfo}
or return;
@@ -593,8 +657,8 @@
}
}
- $self->{$cache_key} = \%subs;
- return $self->{$cache_key};
+ $caches->{$cache_key} = \%subs;
+ return $caches->{$cache_key};
}
@@ -787,12 +851,14 @@
or return;
my $line_calls = {};
- while (my ($sub, $fid_hash) = each %$sub_caller) {
+ # search through all subs to find those that were called
+ # from the fid we're interested in
+ while (my ($subname, $fid_hash) = each %$sub_caller) {
my $line_calls_hash = $fid_hash->{$fid}
or next;
while (my ($line, $calls) = each %$line_calls_hash) {
- $line_calls->{$line}{$sub} = $calls;
+ $line_calls->{$line}{$subname} = $calls;
}
}
@@ -811,6 +877,11 @@
}
+sub _dumper {
+ require Data::Dumper;
+ return Data::Dumper::Dumper(@_);
+}
+
## --- will move out to separate files later ---
# for now these are viewed as private classes
@@ -888,6 +959,17 @@
$values[0] = $self->filename_without_inc;
pop @values; # remove profile ref
return [EMAIL PROTECTED];
+ }
+
+ sub delete_subs_called_info {
+ my $self = shift;
+ my $profile = $self->profile;
+ my $sub_caller = $profile->{sub_caller}
+ or return;
+ my $fid = $self->fid;
+ # remove sub_caller info for calls made *from within* this file
+ delete $_->{$fid} for values %$sub_caller;
+ return;
}
} # end of package
Modified: trunk/t/test09.rdt
==============================================================================
--- trunk/t/test09.rdt (original)
+++ trunk/t/test09.rdt Tue Oct 21 15:51:10 2008
@@ -54,8 +54,7 @@
profile_modes fid_line_time line
profile_modes fid_sub_time sub
sub_caller main::bar 1 13 [ 1 0 0 0 0 0 0 ]
-sub_caller main::bar 2 3 [ 1 0 0 0 0 0 0 ]
-sub_caller main::bar 4 3 [ 1 0 0 0 0 0 0 ]
+sub_caller main::bar 1 2 [ 2 0 0 0 0 0 0 ]
sub_caller main::foo 1 11 [ 1 0 0 0 0 0 0 ]
sub_caller main::foo 1 12 [ 1 0 0 0 0 0 0 ]
sub_subinfo main::bar [ 1 7 9 3 0 0 0 0 ]
Modified: trunk/t/test13.rdt
==============================================================================
--- trunk/t/test13.rdt (original)
+++ trunk/t/test13.rdt Tue Oct 21 15:51:10 2008
@@ -49,7 +49,7 @@
sub_caller main::baz 1 21 [ 1 0 0 0 0 0 0 ]
sub_caller main::foo 1 13 [ 1 0 0 0 0 0 0 ]
sub_caller main::foo 1 14 [ 1 0 0 0 0 0 0 ]
-sub_caller main::foo 2 1 [ 1 0 0 0 0 0 0 ]
+sub_caller main::foo 1 19 [ 1 0 0 0 0 0 0 ]
sub_subinfo main::bar [ 1 7 9 1 0 0 0 0 ]
sub_subinfo main::baz [ 1 11 17 1 0 0 0 0 ]
sub_subinfo main::foo [ 1 3 5 3 0 0 0 0 ]
Added: trunk/t/test20-streval.p
==============================================================================
--- (empty file)
+++ trunk/t/test20-streval.p Tue Oct 21 15:51:10 2008
@@ -0,0 +1,11 @@
+# test merging of sub calls from eval fids
+
+sub foo { print "foo\n" }
+
+my $code = 'foo()';
+
+# call once from particular line
+eval $code;
+
+# call twice from the same line
+eval $code or die $@ for (1,2);
Added: trunk/t/test20-streval.rdt
==============================================================================
--- (empty file)
+++ trunk/t/test20-streval.rdt Tue Oct 21 15:51:10 2008
@@ -0,0 +1,47 @@
+attribute application test20-streval.p
+attribute basetime 0
+attribute clock_id 0
+attribute nv_size 0
+attribute perl_version 0
+attribute profiler_duration 0
+attribute profiler_end_time 0
+attribute profiler_start_time 0
+attribute ticks_per_sec 0
+attribute total_stmts_discounted 0
+attribute total_stmts_duration 0
+attribute total_stmts_measured 0
+attribute xs_version 0
+fid_block_time 1 3 [ 0 3 ]
+fid_block_time 1 5 [ 0 1 ]
+fid_block_time 1 8 0 0
+fid_block_time 1 8 1 1
+fid_block_time 1 8 2 1 [ 0 1 ]
+fid_block_time 1 11 0 0
+fid_block_time 1 11 1 2
+fid_block_time 1 11 2 1 [ 0 2 ]
+fid_fileinfo 1 [ /.../test20-streval.p 1 2 0 0 ]
+fid_fileinfo 2 [ (eval 0)[test20-streval.p:8] 1 8 2 2 0 0 ]
+fid_fileinfo 3 [ (eval 0)[test20-streval.p:11] 1 11 3 2 0 0 ]
+fid_fileinfo 4 [ (eval 0)[test20-streval.p:11] 1 11 4 2 0 0 ]
+fid_line_time 1 3 [ 0 3 ]
+fid_line_time 1 5 [ 0 1 ]
+fid_line_time 1 8 0 0
+fid_line_time 1 8 1 1
+fid_line_time 1 8 2 1 [ 0 1 ]
+fid_line_time 1 11 0 0
+fid_line_time 1 11 1 2
+fid_line_time 1 11 2 1 [ 0 2 ]
+fid_sub_time 1 3 [ 0 3 ]
+fid_sub_time 1 5 [ 0 1 ]
+fid_sub_time 1 8 0 0
+fid_sub_time 1 8 1 1
+fid_sub_time 1 8 2 1 [ 0 1 ]
+fid_sub_time 1 11 0 0
+fid_sub_time 1 11 1 2
+fid_sub_time 1 11 2 1 [ 0 2 ]
+profile_modes fid_block_time block
+profile_modes fid_line_time line
+profile_modes fid_sub_time sub
+sub_caller main::foo 1 11 [ 2 0 0 0 0 0 0 ]
+sub_caller main::foo 1 8 [ 1 0 0 0 0 0 0 ]
+sub_subinfo main::foo [ 1 3 3 3 0 0 0 0 ]
--~--~---------~--~----~------------~-------~--~----~
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]
-~----------~----~----~----~------~----~------~--~---
