Revision: 1186
Author: [email protected]
Date: Sun Apr 18 09:17:15 2010
Log: Assorted work towards string eval support plus collateral tweaks.
new() now returns undef when using callbacks.
::SubInfo normalize_for_test normalizes the sub caller line number
for calls from AutoLoader and Exporter.
FileInfo's can be 'nullified' to make them vanish.
Tests pass, though there are some stray debug warns lying around still.
http://code.google.com/p/perl-devel-nytprof/source/detail?r=1186
Modified:
/trunk/NYTProf.xs
/trunk/lib/Devel/NYTProf/Data.pm
/trunk/lib/Devel/NYTProf/FileInfo.pm
/trunk/lib/Devel/NYTProf/SubInfo.pm
/trunk/t/lib/NYTProfTest.pm
/trunk/t/test14.rdt
=======================================
--- /trunk/NYTProf.xs Tue Apr 13 03:05:10 2010
+++ /trunk/NYTProf.xs Sun Apr 18 09:17:15 2010
@@ -4851,11 +4851,14 @@
}
if (cb && SvROK(cb)) {
load_profile_to_callback(aTHX_ in, SvRV(cb));
- RETVAL = newHV(); /* Can we change this to PL_sv_undef? */
- } else
+ RETVAL = &PL_sv_undef;
+ }
+ else {
RETVAL = load_profile_to_hv(aTHX_ in);
+ }
if ((result = NYTP_close(in, 0)))
logwarn("Error closing profile data file: %s\n", strerror(result));
+
OUTPUT:
RETVAL
=======================================
--- /trunk/lib/Devel/NYTProf/Data.pm Wed Mar 31 13:30:49 2010
+++ /trunk/lib/Devel/NYTProf/Data.pm Sun Apr 18 09:17:15 2010
@@ -83,6 +83,9 @@
$file,
$args->{callback},
);
+
+ return undef if $args->{callback};
+
bless $profile => $class;
my $fid_fileinfo = $profile->{fid_fileinfo};
@@ -98,6 +101,40 @@
# bless sub_subinfo data
(my $sub_class = $class) =~ s/\w+$/SubInfo/;
$_ and bless $_ => $sub_class for values %$sub_subinfo;
+
+ $profile->_clear_caches;
+
+ # Where a given eval() has been invoked more than once
+ # rollup the corresponding fids if they're "uninteresting".
+ # Currently uninteresting means:
+ # - defines no subs, and
+ # - has no evals
+ my %eval_places;
+ for my $fi ($profile->eval_fileinfos) {
+ 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;
+next;
+ 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 @calls; # ignore if the eval calls 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_and_discard_evals(@$siblings);
+ }
+ }
$profile->_clear_caches;
@@ -235,7 +272,8 @@
sub all_fileinfos {
my @all = @{shift->{fid_fileinfo}};
shift @all; # drop fid 0
- return @all;
+ # return all non-nullified fileinfos
+ return grep { $_->fid } @all;
}
sub eval_fileinfos {
@@ -264,34 +302,9 @@
return undef;
}
- return $self->{fid_fileinfo}[$fid];
-}
-
-
-# map of { eval_fid => base_fid, ... }
-sub eval_fid_2_base_fid_map {
- my ($self, $flatten_evals) = @_;
- $flatten_evals ||= 0;
-
- my $caches = $self->_caches;
- my $cache_key = "eval_fid_2_base_fid_map:$flatten_evals";
- return $caches->{$cache_key} if $caches->{$cache_key};
-
- my $fid_fileinfo = $self->{fid_fileinfo} || [];
- my $eval_fid_map = {};
-
- for my $fi (@$fid_fileinfo) {
- my $base_fi = $fi && $fi->eval_fi
- or next;
-
- 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;
- }
-
- $caches->{$cache_key} = $eval_fid_map;
- return $eval_fid_map;
+ my $fi = $self->{fid_fileinfo}[$fid];
+ return undef unless defined $fi->fid; # nullified?
+ return $fi;
}
@@ -346,22 +359,27 @@
if (my $hook = $args->{skip_fileinfo_hook}) {
- # for fid_fileinfo don't dump internal details of lib modules
+ # for fid_fileinfo elements...
if ($path->[0] eq 'fid_fileinfo' && @$path==2) {
- my $fi = $self->fileinfo_of($value->[0]);
+ my $fi = $value;
+
+ # skip nullified fileinfo
+ return undef unless $fi->fid;
+
+ # don't dump internal details of lib modules
return ({ skip_internal_details => scalar $hook->($fi,
$path, $value) }, $value);
}
# skip sub_subinfo data for 'library modules'
if ($path->[0] eq 'sub_subinfo' && @$path==2 && $value->[0]) {
my $fi = $self->fileinfo_of($value->[0]);
- return undef if $hook->($fi, $path, $value);
+ return undef if !$fi or $hook->($fi, $path, $value);
}
# skip fid_*_time data for 'library modules'
if ($path->[0] =~ /^fid_\w+_time$/ && @$path==2) {
my $fi = $self->fileinfo_of($path->[1]);
- return undef if $hook->($fi, $path, $value)
+ return undef if !$fi or $hook->($fi, $path, $value);
}
}
return ({}, $value);
@@ -400,7 +418,9 @@
my $value = ($is_hash) ? $r->{$key} : $r->[$key];
# skip undef elements in array
- next if !defined($value) && !$is_hash;
+ next if !$is_hash && !defined($value);
+ # skip refs to empty arrays in array
+ next if !$is_hash && ref $value eq 'ARRAY' && !...@$value;
my $dump_opts = {};
if ($callback) {
@@ -545,12 +565,8 @@
my $self = shift;
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) {
- my $filename = $fid_fileinfo->[$fid][0];
- $filename_to_fid->{$filename} = $fid;
- }
+ $filename_to_fid->{$_->filename} = $_->fid for
$self->all_fileinfos;
$filename_to_fid;
};
}
@@ -643,7 +659,7 @@
or return undef;
while ($fileinfo->[1]) { # is an eval
-
+carp "using fid_filename($fid) on eval"; # XXX
# eg string eval
# eg [ "(eval 6)[/usr/local/perl58-i/lib/5.8.6/Benchmark.pm:634]",
2, 634 ]
warn sprintf "fid_filename: fid %d -> %d for %s\n", $fid,
$fileinfo->[1], $fileinfo->[0]
@@ -690,10 +706,10 @@
return if not $fid; # sub has no known file
- my $fileinfo = $fid && $self->{fid_fileinfo}->[$fid]
+ 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
# 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 Mon Apr 5 16:22:16 2010
+++ /trunk/lib/Devel/NYTProf/FileInfo.pm Sun Apr 18 09:17:15 2010
@@ -2,6 +2,8 @@
use strict;
+use List::Util qw(sum);
+
use Devel::NYTProf::Util qw(strip_prefix_from_paths);
use Devel::NYTProf::Constants qw(
@@ -45,7 +47,7 @@
# general purpose hash - mainly a hack to help kill of Reader.pm
sub meta { shift->[NYTP_FIDi_meta()] ||= {} }
-# array of fileinfo's for each string eval in the file, else undef
+# array of fileinfo's for each string eval in the file
sub has_evals {
my ($self, $include_nested) = @_;
@@ -61,6 +63,28 @@
return @eval_fis;
}
+
+
+sub _nullify {
+ my $self = shift;
+ @$self = (); # Zap!
+}
+
+
+sub _delete_eval {
+ my ($self, $eval_fi) = @_;
+
+ my $eval_fis = $self->[NYTP_FIDi_HAS_EVALS()]
+ or return;
+ my $count = @$eval_fis;
+ @$eval_fis = grep { $_ != $eval_fi } @$eval_fis;
+ warn "_delete_eval missed" if @$eval_fis == $count;
+
+ # XXX needs to update NYTP_FIDi_SUBS_DEFINED NYTP_FIDi_SUBS_CALLED
+ # by moving relevant data up the the parent
+
+ return;
+}
# return a ref to a hash of { subname => subinfo, ... }
@@ -151,18 +175,16 @@
for (@$line_data) {
next unless $_;
$excl_time += $_->[0];
- # XXX this old mechanism should be deprecated soon
- if (my $eval_lines = $_->[2]) {
- # line contains a string eval
- $excl_time += $_->[0] for values %$eval_lines;
- }
}
return $excl_time;
}
sub sum_of_stmts_count {
- my ($self) = @_;
+ my ($self, $incl_nested_evals) = @_;
+
+ return sum(map { $_->sum_of_stmts_count(0) } $self,
$self->has_evals(1))
+ if $incl_nested_evals;
my $ref = \$self->[NYTP_FIDi_sum_stmts_count()];
$$ref = $self->_sum_of_line_time_data(1)
@@ -172,7 +194,10 @@
}
sub sum_of_stmts_time {
- my ($self) = @_;
+ my ($self, $incl_nested_evals) = @_;
+
+ return sum(map { $_->sum_of_stmts_time(0) } $self, $self->has_evals(1))
+ if $incl_nested_evals;
my $ref = \$self->[NYTP_FIDi_sum_stmts_times()];
$$ref = $self->_sum_of_line_time_data(0)
@@ -208,6 +233,27 @@
sub is_pmc {
return (shift->flags & NYTP_FIDf_IS_PMC());
}
+
+
+sub collapse_and_discard_evals {
+ my $self = shift;
+
+ for my $eval_fi (@_) {
+ die "Can't rollup_and_discard_evals into non-parent"
+ if $eval_fi->eval_fi != $self;
+ # XXX check if parent has already been collapsed
+
+ # XXX doesn't update model to edit details for
+ # subs defines, subs called, or evals etc.
+
+ my $line_time_data = $self->line_time_data; # XXX line only
+ my $tld = $line_time_data->[$eval_fi->eval_line] ||= [];
+ $tld->[0] += $eval_fi->sum_of_stmts_time(1);
+
+ $self->_delete_eval($eval_fi);
+ $eval_fi->_nullify;
+ }
+}
# should return the filename that the application used
=======================================
--- /trunk/lib/Devel/NYTProf/SubInfo.pm Mon Apr 5 16:22:16 2010
+++ /trunk/lib/Devel/NYTProf/SubInfo.pm Sun Apr 18 09:17:15 2010
@@ -218,16 +218,21 @@
$self->[NYTP_SIi_EXCL_RTIME] = 0;
$self->[NYTP_SIi_RECI_RTIME] = 0;
- # { fid => { line => [ count, incl, excl, ucpu, scpu, reci, recdepth ]
} }
- my $callers = $self->caller_fid_line_places || {};
-
- # delete calls from modules shipped with perl that some tests use
- # (because the line numbers vary between perl versions)
+ # { fid => { line => [ count, incl, excl, spare3, spare4, reci,
recdepth ] } }
+ my $callers = $self->[NYTP_SIi_CALLED_BY] || {};
+
+ # calls from modules shipped with perl cause problems for tests
+ # because the line numbers vary between perl versions, so here we
+ # edit the line number of calls from these modules
for my $fid (keys %$callers) {
next if not $fid;
my $fileinfo = $profile->fileinfo_of($fid) or next;
next if $fileinfo->filename !~ /(AutoLoader|Exporter)\.pm$/;
- delete $callers->{$fid};
+
+ # normalize the lines X,Y,Z to 1,2,3
+ my %lines = %{ delete $callers->{$fid} };
+ my @lines = @lines{sort { $a <=> $b } keys %lines};
+ $callers->{$fid} = { map { $_ => shift @lines } 1...@lines };
}
# zero per-call-location subroutine inclusive time
=======================================
--- /trunk/t/lib/NYTProfTest.pm Mon Apr 5 16:22:16 2010
+++ /trunk/t/lib/NYTProfTest.pm Sun Apr 18 09:17:15 2010
@@ -343,6 +343,7 @@
sub run_perl_command {
my ($cmd, $show_stdout) = @_;
+ local $ENV{PERL5LIB} = $perl5lib;
run_command("$this_perl $cmd", $show_stdout);
}
=======================================
--- /trunk/t/test14.rdt Mon Apr 5 16:22:16 2010
+++ /trunk/t/test14.rdt Sun Apr 18 09:17:15 2010
@@ -58,8 +58,8 @@
sub_subinfo main::RUNTIME [ 1 1 1 0 0 0 0 0 ]
sub_subinfo test14::BEGIN [ 2 2 2 0 0 0 0 0 ]
sub_subinfo test14::bar [ 2 16 18 1 0 0 0 0 ]
-sub_subinfo test14::bar called_by 3 51 [ 1 0 0 0 0 0 0
main::RUNTIME ]
+sub_subinfo test14::bar called_by 3 1 [ 1 0 0 0 0 0 0
main::RUNTIME ]
sub_subinfo test14::foo [ 2 12 14 1 0 0 0 0 ]
-sub_subinfo test14::foo called_by 3 51 [ 1 0 0 0 0 0 0
main::RUNTIME ]
+sub_subinfo test14::foo called_by 3 1 [ 1 0 0 0 0 0 0
main::RUNTIME ]
sub_subinfo test14::pre [ 2 8 8 1 0 0 0 0 ]
sub_subinfo test14::pre called_by 1 17 [ 1 0 0 0 0 0 0
main::RUNTIME ]
--
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]
