Author: tim.bunce
Date: Mon Oct 27 16:49:08 2008
New Revision: 559
Modified:
trunk/bin/nytprofhtml
trunk/lib/Devel/NYTProf/Data.pm
trunk/lib/Devel/NYTProf/Reader.pm
trunk/t/test09.rdt
trunk/t/test13.rdt
trunk/t/test20-streval.p
trunk/t/test20-streval.rdt
Log:
Major improvement to handling of string evals...
Don't call (the recently added) _migrate_sub_callers_from_eval_fids method
as that wasn't a good approach - destroys information.
Enhance the data model to make it easier to reason about string eval fids.
In reports subs now list calls from string evals (including nested string
evals)
and lins with string evals list all the subs called by all the strings
executed
by that eval. Yeah!
Modified: trunk/bin/nytprofhtml
==============================================================================
--- trunk/bin/nytprofhtml (original)
+++ trunk/bin/nytprofhtml Mon Oct 27 16:49:08 2008
@@ -289,6 +289,7 @@
@callers = sort { $b->[2] <=> $a->[2] || $b->[3] <=>
$a->[3] } @callers;
for my $caller (@callers) {
my ($fid, $line, $count, $incl_time, $excl_time) =
@$caller;
+ my $fi = $profile->fileinfo_of($fid);
my @subnames = $profile->subname_at_file_line($fid,
$line);
my $subname = (@subnames) ? " by " . join(" or ",
@subnames) : "";
@@ -299,14 +300,22 @@
my $times = sprintf " (%s+%s)", fmt_time($excl_time),
fmt_time($incl_time - $excl_time);
- my $filename = $profile->fid_filename($fid);
+ my $filename = $fi->filename($fid);
+ my $line_desc = "line $line of $filename";
+ # chase string eval chain back to a real file
+ while ( my ($outer_fileinfo, $outer_line) = $fi->outer
) {
+ ($filename, $line) = ($outer_fileinfo->filename,
$outer_line);
+ $line_desc .= sprintf " at line %s of %s", $line,
$filename;
+ $fi = $outer_fileinfo;
+ }
+
my $href =
$reporter->get_file_stats()->{$filename}{html_safe} || "unknown";
- $filename = $filename eq $thisfile ? "" : " of $filename";
+ $line_desc =~ s/ of $filename$// if $filename eq
$thisfile;
push @prologue,
- sprintf q{# %*s times%s%s at <a
href="%s#%d">line %d%s</a>%s},
- length($max_calls), $count, $times,
$subname, "$href.html", $line, $line,
- $filename, $avg_time;
+ sprintf q{# %*s times%s%s at <a
href="%s#%d">%s</a>%s},
+ length($max_calls), $count, $times,
$subname, "$href.html", $line,
+ $line_desc, $avg_time;
$prologue[-1] =~ s/^(# +)1 times/$1 once/; # better
English
}
}
Modified: trunk/lib/Devel/NYTProf/Data.pm
==============================================================================
--- trunk/lib/Devel/NYTProf/Data.pm (original)
+++ trunk/lib/Devel/NYTProf/Data.pm Mon Oct 27 16:49:08 2008
@@ -91,7 +91,7 @@
(my $sub_class = $class) =~ s/\w+$/ProfSub/;
$_ and bless $_ => $sub_class for values %$sub_subinfo;
- $profile->_migrate_sub_callers_from_eval_fids;
+ #$profile->_migrate_sub_callers_from_eval_fids;
# XXX merge evals - should become a method optionally called here
# (which uses other methods to do the work and those methods
@@ -194,18 +194,38 @@
return $self->{fid_fileinfo}[$fid];
}
-sub eval_fid_map {
- my $self = shift;
+
+# map of { eval_fid => base_fid, ... }
+sub eval_fid_2_base_fid_map {
+ my ($self, $flatten_evals) = @_;
+
my $fid_fileinfo = $self->{fid_fileinfo} || [];
my $eval_fid_map = {};
- for my $fileinfo (@$fid_fileinfo) {
- my $base_fid = $fileinfo && $fileinfo->eval_fid
+
+ for my $fi (@$fid_fileinfo) {
+ my $base_fi = $fi && $fi->eval_fi
or next;
- $eval_fid_map->{ $fileinfo->fid } = $base_fid;
+
+ while ($flatten_evals and my $b_eval_fi = $base_fi->eval_fi) {
+ $base_fi = $b_eval_fi;
+ }
+ $eval_fid_map->{ $fi->fid } = $base_fi->fid;
}
return $eval_fid_map;
}
+
+# map of { base_fid => [ eval_fid, ...]. }
+sub base_fid_2_eval_fids_map {
+ my ($self, $flatten_evals) = @_;
+ my $e2b = $self->eval_fid_2_base_fid_map($flatten_evals);
+ my $b2e = {};
+ while ( my ($eval_fid, $base_fid) = each %$e2b ) {
+ push @{ $b2e->{$base_fid} }, $eval_fid;
+ }
+ return $b2e;
+}
+
sub fid_sub_calls_map {
my $self = shift;
my $sub_caller = $self->{sub_caller} || {};
@@ -561,7 +581,7 @@
# migrate sub calls made from evals to be calls from the base fid
#
# map of { eval_fid => base_fid, ... }
- my $eval_fid_map = $self->eval_fid_map;
+ my $eval_fid_map = $self->eval_fid_2_base_fid_map;
# map of { fid => { subs called from fid... }, ... }
my $fid_sub_calls_map = $self->fid_sub_calls_map;
#
@@ -872,21 +892,41 @@
sub line_calls_for_file {
- my ($self, $fid) = @_;
-
+ my ($self, $fid, $flatten_evals) = @_;
$fid = $self->resolve_fid($fid);
+
my $sub_caller = $self->{sub_caller}
or return;
+ # hash of fids we're interested in
+ my %fids = ($fid => 1);
+ # add in all the fids for evals compiled in this fid
+ my $b2e = $self->base_fid_2_eval_fids_map($flatten_evals);
+ $fids{$_} = 1 for @{ $b2e->{$fid} || [] };
+
my $line_calls = {};
# search through all subs to find those that were called
- # from the fid we're interested in
+ # from the fid we're interested in, or any eval fids in that
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}{$subname} = $calls;
+ while ( my ($caller_fid, $line_calls_hash) = each %$fid_hash ) {
+ next unless $fids{ $caller_fid };
+
+ my $caller_fi = $self->fileinfo_of($caller_fid);
+ my ($outer_fi, $outer_line) = $caller_fi->outer(1);
+
+ while (my ($line, $callinfo) = each %$line_calls_hash) {
+ my $caller_line = $outer_line || $line;
+ my $ci = $line_calls->{$caller_line}{$subname} ||= [];
+ if ([EMAIL PROTECTED]) { # typical case
+ @$ci = @$callinfo;
+ }
+ else { # e.g., multiple calls inside the same
string eval
+ #warn "merging calls to $subname from fid $caller_fid
line $caller_line ($outer_line || $line)";
+ $ci->[$_] += $callinfo->[$_] for 0..5;
+ $ci->[6] = $callinfo->[6] if $callinfo->[6] >
$ci->[6]; # NYTP_SCi_REC_DEPTH
+ }
+ }
}
}
@@ -921,6 +961,7 @@
sub filename { shift->[0] }
sub eval_fid { shift->[1] }
+ sub eval_fi { return $_[0]->profile->fileinfo_of($_[0]->eval_fid ||
return) }
sub eval_line { shift->[2] }
sub fid { shift->[3] }
sub flags { shift->[4] }
@@ -958,12 +999,17 @@
}
sub outer {
- my $self = shift;
- my $fid = $self->eval_fid
+ my ($self, $recurse) = @_;
+ my $fi = $self->eval_fi
or return;
- my $fileinfo = $self->profile->fileinfo_of($fid);
- return $fileinfo unless wantarray;
- return ($fileinfo, $self->eval_line);
+ my $prev = $self;
+
+ while ($recurse and my $eval_fi = $fi->eval_fi) {
+ $prev = $fi;
+ $fi = $eval_fi;
+ }
+ return $fi unless wantarray;
+ return ($fi, $prev->eval_line);
}
@@ -1083,7 +1129,7 @@
my $callers = $self->callers
or return 0;
- # scalar: count of the number of distinct locations sub iss called
from
+ # scalar: count of the number of distinct locations sub is called
from
# list: array of [ fid, line, @... ]
my @callers;
warn "caller_places in list context not implemented/tested yet";
Modified: trunk/lib/Devel/NYTProf/Reader.pm
==============================================================================
--- trunk/lib/Devel/NYTProf/Reader.pm (original)
+++ trunk/lib/Devel/NYTProf/Reader.pm Mon Oct 27 16:49:08 2008
@@ -363,7 +363,7 @@
'time/call' =>
calculate_median_absolute_deviation($totalsAccum{'time/call'}||[]),
);
- my $line_calls_hash = $profile->line_calls_for_file($filestr);
+ my $line_calls_hash = $profile->line_calls_for_file($filestr, 1);
my $subs_defined_hash = $profile->subs_defined_in_file($filestr,
1);
# the output file name that will be open later. Not including
directory at this time.
Modified: trunk/t/test09.rdt
==============================================================================
--- trunk/t/test09.rdt (original)
+++ trunk/t/test09.rdt Mon Oct 27 16:49:08 2008
@@ -54,7 +54,8 @@
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 1 2 [ 2 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::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 Mon Oct 27 16:49:08 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 1 19 [ 1 0 0 0 0 0 0 ]
+sub_caller main::foo 2 1 [ 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 ]
Modified: trunk/t/test20-streval.p
==============================================================================
--- trunk/t/test20-streval.p (original)
+++ trunk/t/test20-streval.p Mon Oct 27 16:49:08 2008
@@ -9,3 +9,6 @@
# call twice from the same line
eval $code or die $@ for (1,2);
+
+# once from an eval inside an eval
+eval "eval q{$code}";
Modified: trunk/t/test20-streval.rdt
==============================================================================
--- trunk/t/test20-streval.rdt (original)
+++ trunk/t/test20-streval.rdt Mon Oct 27 16:49:08 2008
@@ -11,7 +11,7 @@
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 3 [ 0 4 ]
fid_block_time 1 5 [ 0 1 ]
fid_block_time 1 8 0 0
fid_block_time 1 8 1 1
@@ -19,11 +19,19 @@
fid_block_time 1 11 0 0
fid_block_time 1 11 1 2
fid_block_time 1 11 2 1 [ 0 2 ]
+fid_block_time 1 14 0 0
+fid_block_time 1 14 1 1
+fid_block_time 1 14 2 1 [ 0 1 ]
+fid_block_time 5 1 0 0
+fid_block_time 5 1 1 0
+fid_block_time 5 1 2 1 [ 0 1 ]
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_fileinfo 5 [ (eval 0)[test20-streval.p:14] 1 14 5 2 0 0 ]
+fid_fileinfo 6 [ (eval 0)[(eval 0)[test20-streval.p:14]:1] 5 1 6 2 0 0
]
+fid_line_time 1 3 [ 0 4 ]
fid_line_time 1 5 [ 0 1 ]
fid_line_time 1 8 0 0
fid_line_time 1 8 1 1
@@ -31,7 +39,13 @@
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_line_time 1 14 0 0
+fid_line_time 1 14 1 1
+fid_line_time 1 14 2 1 [ 0 1 ]
+fid_line_time 5 1 0 0
+fid_line_time 5 1 1 0
+fid_line_time 5 1 2 1 [ 0 1 ]
+fid_sub_time 1 3 [ 0 4 ]
fid_sub_time 1 5 [ 0 1 ]
fid_sub_time 1 8 0 0
fid_sub_time 1 8 1 1
@@ -39,9 +53,17 @@
fid_sub_time 1 11 0 0
fid_sub_time 1 11 1 2
fid_sub_time 1 11 2 1 [ 0 2 ]
+fid_sub_time 1 14 0 0
+fid_sub_time 1 14 1 1
+fid_sub_time 1 14 2 1 [ 0 1 ]
+fid_sub_time 5 1 0 0
+fid_sub_time 5 1 1 0
+fid_sub_time 5 1 2 1 [ 0 1 ]
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 ]
+sub_caller main::foo 2 1 [ 1 0 0 0 0 0 0 ]
+sub_caller main::foo 3 1 [ 1 0 0 0 0 0 0 ]
+sub_caller main::foo 4 1 [ 1 0 0 0 0 0 0 ]
+sub_caller main::foo 6 1 [ 1 0 0 0 0 0 0 ]
+sub_subinfo main::foo [ 1 3 3 4 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]
-~----------~----~----~----~------~----~------~--~---
