Revision: 1416
Author: [email protected]
Date: Thu Mar 22 08:48:06 2012
Log: nytprofmerge de-tab
http://code.google.com/p/perl-devel-nytprof/source/detail?r=1416
Modified:
/trunk/bin/nytprofmerge
=======================================
--- /trunk/bin/nytprofmerge Thu Mar 22 08:46:17 2012
+++ /trunk/bin/nytprofmerge Thu Mar 22 08:48:06 2012
@@ -70,16 +70,16 @@
# XXX overflow isn't passed in or through
if ($tag eq 'TIME_LINE') {
- $out->write_time_line($ticks, 0, $fid, $line);
+ $out->write_time_line($ticks, 0, $fid, $line);
} else {
- $out->write_time_block($ticks, 0, $fid, $line, $block_line, $sub_line);
+ $out->write_time_block($ticks, 0, $fid, $line, $block_line,
$sub_line);
}
}
# Croak if any of these attributes differ between profiles
my %identical = map {$_, 1}
qw (PL_perldb clock_id nv_size perl_version
- ticks_per_sec xs_version);
+ ticks_per_sec xs_version);
# Effectively, these are global variables. Sorry.
my $input;
@@ -89,117 +89,117 @@
my %dispatcher =
(
'' => sub {
- die "Unknown tag '$_[0]' in $input\n";
+ die "Unknown tag '$_[0]' in $input\n";
},
VERSION => sub {
- my (undef, $major, $minor) = @_;
- my $this_version = "$major $minor";
- if($version) {
- die "Incompatible version '$this_version' in $input,
expected '$version'"
- unless $this_version eq $version;
- } else {
- $version = $this_version;
- $out->write_header($major, $minor);
- }
+ my (undef, $major, $minor) = @_;
+ my $this_version = "$major $minor";
+ if($version) {
+ die "Incompatible version '$this_version' in $input,
expected '$version'"
+ unless $this_version eq $version;
+ } else {
+ $version = $this_version;
+ $out->write_header($major, $minor);
+ }
},
COMMENT => sub {
- my (undef, $text) = @_;
- chomp $text; # Arguably this is a bug in the callback interface.
- # This isn't true unless we enable compression ourselves, and if we
- # do that, the low level code will write out a correct comment
- # automatically.
- return if $text =~ /\ACompressed at level \d with zlib [0-9.]+\z/;
- $out->write_comment($text)
+ my (undef, $text) = @_;
+ chomp $text; # Arguably this is a bug in the callback interface.
+ # This isn't true unless we enable compression ourselves, and if
we
+ # do that, the low level code will write out a correct comment
+ # automatically.
+ return if $text =~ /\ACompressed at level \d with zlib [0-9.]+\z/;
+ $out->write_comment($text)
},
ATTRIBUTE => sub {
- my (undef, $key, $value) = @_;
- if ($identical{$key}) {
- if (exists $attributes{$key}) {
- if ($attributes{$key} ne $value) {
- die ("In $input, attribute '$key' has value '$value', which differs
from the previous value for that key, '$attributes{$key}'\n");
- }
- } else {
- $attributes{$key} = $value;
- $out->write_attribute($key, $value);
- }
- } else {
- push @{$attributes{$key}}, $value;
- }
+ my (undef, $key, $value) = @_;
+ if ($identical{$key}) {
+ if (exists $attributes{$key}) {
+ if ($attributes{$key} ne $value) {
+ die ("In $input, attribute '$key' has value '$value',
which differs from the previous value for that key, '$attributes{$key}'\n");
+ }
+ } else {
+ $attributes{$key} = $value;
+ $out->write_attribute($key, $value);
+ }
+ } else {
+ push @{$attributes{$key}}, $value;
+ }
},
START_DEFLATE => sub {
- if (!$deflating && $out->can('start_deflate_write_tag_comment')) {
- $out->start_deflate_write_tag_comment;
- ++$deflating;
- }
+ if (!$deflating && $out->can('start_deflate_write_tag_comment')) {
+ $out->start_deflate_write_tag_comment;
+ ++$deflating;
+ }
},
PID_START => sub {
- my (undef, $pid, $parent, $time) = @_;
- $out->write_process_start($pid, $parent, $time);
+ my (undef, $pid, $parent, $time) = @_;
+ $out->write_process_start($pid, $parent, $time);
},
PID_END => sub {
- my (undef, $pid, $time) = @_;
- $out->write_process_end($pid, $time);
+ my (undef, $pid, $time) = @_;
+ $out->write_process_end($pid, $time);
},
NEW_FID => sub {
- my (undef, $fid, $eval_fid, $eval_line, $flags, $size, $mtime, $name) =
@_;
-
- return unless $pending_fids[$fid];
- my ($new_fid, $new_eval_fid) = @{$pending_fids[$fid]};
-
- $out->write_new_fid($new_fid, $new_eval_fid, $eval_line, $flags,
- $size, $mtime, $name);
+ my (undef, $fid, $eval_fid, $eval_line, $flags, $size, $mtime,
$name) = @_;
+
+ return unless $pending_fids[$fid];
+ my ($new_fid, $new_eval_fid) = @{$pending_fids[$fid]};
+
+ $out->write_new_fid($new_fid, $new_eval_fid, $eval_line, $flags,
+ $size, $mtime, $name);
},
TIME_BLOCK => \&_write_time_block_or_line,
TIME_LINE => \&_write_time_block_or_line,
DISCOUNT => sub {
- $out->write_discount();
+ $out->write_discount();
},
SUB_INFO => sub {
- my (undef, $fid, $first_line, $last_line, $name) = @_;
-
- my $output_fid = $pending_subs{"$fid,$first_line,$last_line,$name"};
- return unless defined $output_fid;
-
- $out->write_sub_info($output_fid, $name, $first_line, $last_line);
+ my (undef, $fid, $first_line, $last_line, $name) = @_;
+
+ my $output_fid =
$pending_subs{"$fid,$first_line,$last_line,$name"};
+ return unless defined $output_fid;
+
+ $out->write_sub_info($output_fid, $name, $first_line, $last_line);
},
SUB_CALLERS => sub {
- my (undef, $fid, $line, $count, $incl_time, $excl_time, $reci_time,
$rec_depth, $called, $caller) = @_;
- confess("No mapping for $fid") unless defined $fids{$fid};
- $fid = $fids{$fid};
- my $mapped_fid = $map_range{$fid}[$line];
- $fid = $mapped_fid if defined $mapped_fid;
-
- if ($callers{"$fid,$line"}{$called}{$caller}) {
- my $sum = $callers{"$fid,$line"}{$called}{$caller};
- $sum->{count} += $count;
- $sum->{incl} += $incl_time;
- $sum->{excl} += $excl_time;
- $sum->{reci} += $reci_time;
- $sum->{depth} = $rec_depth if $rec_depth > $sum->{depth};
- } else {
- # New;
- $callers{"$fid,$line"}{$called}{$caller} =
- {
- depth => $rec_depth,
- count => $count,
- incl => $incl_time,
- excl => $excl_time,
- reci => $reci_time,
- };
- }
+ my (undef, $fid, $line, $count, $incl_time, $excl_time,
$reci_time, $rec_depth, $called, $caller) = @_;
+ confess("No mapping for $fid") unless defined $fids{$fid};
+ $fid = $fids{$fid};
+ my $mapped_fid = $map_range{$fid}[$line];
+ $fid = $mapped_fid if defined $mapped_fid;
+
+ if ($callers{"$fid,$line"}{$called}{$caller}) {
+ my $sum = $callers{"$fid,$line"}{$called}{$caller};
+ $sum->{count} += $count;
+ $sum->{incl} += $incl_time;
+ $sum->{excl} += $excl_time;
+ $sum->{reci} += $reci_time;
+ $sum->{depth} = $rec_depth if $rec_depth > $sum->{depth};
+ } else {
+ # New;
+ $callers{"$fid,$line"}{$called}{$caller} =
+ {
+ depth => $rec_depth,
+ count => $count,
+ incl => $incl_time,
+ excl => $excl_time,
+ reci => $reci_time,
+ };
+ }
},
SRC_LINE => sub {
- my (undef, $fid, $line, $text) = @_;
- confess("No mapping for $fid") unless defined $fids{$fid};
- $fid = $fids{$fid};
- # Is this a subroutine (re)defined in an eval?
- my $mapped_fid = $map_range{$fid}[$line];
- $fid = $mapped_fid if defined $mapped_fid;
- $out->write_src_line($fid, $line, $text);
+ my (undef, $fid, $line, $text) = @_;
+ confess("No mapping for $fid") unless defined $fids{$fid};
+ $fid = $fids{$fid};
+ # Is this a subroutine (re)defined in an eval?
+ my $mapped_fid = $map_range{$fid}[$line];
+ $fid = $mapped_fid if defined $mapped_fid;
+ $out->write_src_line($fid, $line, $text);
},
);
@@ -209,88 +209,88 @@
%pending_subs = ();
Devel::NYTProf::Data->new({filename => $input, callback => {
- NEW_FID => sub {
- my (undef, $fid, $eval_fid, $eval_line, $flags, $size, $mtime, $name)
= @_;
- my ($new_fid, $new_eval_fid);
- if($eval_fid) {
- # Generally, treat every eval as distinct, even at the same
location
- $new_eval_fid = $fids{$eval_fid};
-
- # Sanity check. Should never happen except that
- # if $eval_fid < $fid then this is a known problem
- # with evals fids getting profiled/output before the parent fid
- warn("unknown eval_fid $eval_fid in $input fid $fid\n")
- unless defined $new_eval_fid;
-
- $new_fid = $next_fid++;
- $fids{$fid} = $new_fid;
-
- # But also track the first fid to be allocated at that line of
the eval
- my $folded_fid = $fids_folded{$eval_fid};
- Carp::cluck("unknown folded eval_fid $eval_fid in $input fid
$fid")
- unless defined $folded_fid;
-
- my $corresponding_eval = $eval_to_fid{"$folded_fid,$eval_line"};
- if (!defined $corresponding_eval) {
- # Not seen a fid generated in an eval at this location
before
- $eval_to_fid{"$folded_fid,$eval_line"} = $new_fid;
- $fids_folded{$fid} = $new_fid;
- } else {
- $fids_folded{$fid} = $corresponding_eval;
- }
- } else {
- $new_eval_fid = $eval_fid;
- $new_fid = $file_to_fid{$name};
-
- if(defined $new_fid) {
- $fids_folded{$fid} = $fids{$fid} = $new_fid;
- return;
- }
-
- $new_fid = $next_fid++;
- $fids_folded{$fid} = $fids{$fid} = $new_fid;
- $file_to_fid{$name} = $new_fid;
- }
- $fid_to_file{$new_fid} = $name;
- $pending_fids[$fid] = [$new_fid, $new_eval_fid];
- },
- SUB_INFO => sub {
- my (undef, $fid, $first_line, $last_line, $name) = @_;
- my $output_fid;
- if ($name =~ $sub_is_anon_in_eval) {
- confess("No mapping for $fid") unless defined $fids{$fid};
- $output_fid = $fids{$fid};
- $seen_subs{"$output_fid,$name"} ||= "$first_line,$last_line";
- } else {
- confess("No mapping for $fid") unless defined
$fids_folded{$fid};
- my $folded = $fids_folded{$fid};
- my $seen = $seen_subs{"$folded,$name"};
- if (defined $seen && $seen ne "$first_line,$last_line") {
- # Warn that we are not folding
-
- # Carry on, and output a SUB_INFO block for this fid
- $output_fid = $fid;
- } else {
- # This subroutine has be (re)defined in two distinct
- # evals, but appears to be identical. So for this lines
- # range in the second eval, treat profiling data as if it
- # came from the fid of the first eval, so that all calls
- # to the sub are collated.
-
- # Have to use the mapped fid as the key to this hash, as
- # only the mapped fids are are unique
- my $mapped_fid = $fids{$fid};
- $map_range{$mapped_fid}[$_] = $folded
- for $first_line .. $last_line;
-
- return if defined $seen;
-
- $seen_subs{"$folded,$name"} = "$first_line,$last_line";
- $output_fid = $folded;
- }
- }
- $pending_subs{"$fid,$first_line,$last_line,$name"} = $output_fid;
- }
+ NEW_FID => sub {
+ my (undef, $fid, $eval_fid, $eval_line, $flags, $size, $mtime,
$name) = @_;
+ my ($new_fid, $new_eval_fid);
+ if($eval_fid) {
+ # Generally, treat every eval as distinct, even at the
same location
+ $new_eval_fid = $fids{$eval_fid};
+
+ # Sanity check. Should never happen except that
+ # if $eval_fid < $fid then this is a known problem
+ # with evals fids getting profiled/output before the
parent fid
+ warn("unknown eval_fid $eval_fid in $input fid $fid\n")
+ unless defined $new_eval_fid;
+
+ $new_fid = $next_fid++;
+ $fids{$fid} = $new_fid;
+
+ # But also track the first fid to be allocated at that
line of the eval
+ my $folded_fid = $fids_folded{$eval_fid};
+ Carp::cluck("unknown folded eval_fid $eval_fid in $input
fid $fid")
+ unless defined $folded_fid;
+
+ my $corresponding_eval =
$eval_to_fid{"$folded_fid,$eval_line"};
+ if (!defined $corresponding_eval) {
+ # Not seen a fid generated in an eval at this location
before
+ $eval_to_fid{"$folded_fid,$eval_line"} = $new_fid;
+ $fids_folded{$fid} = $new_fid;
+ } else {
+ $fids_folded{$fid} = $corresponding_eval;
+ }
+ } else {
+ $new_eval_fid = $eval_fid;
+ $new_fid = $file_to_fid{$name};
+
+ if(defined $new_fid) {
+ $fids_folded{$fid} = $fids{$fid} = $new_fid;
+ return;
+ }
+
+ $new_fid = $next_fid++;
+ $fids_folded{$fid} = $fids{$fid} = $new_fid;
+ $file_to_fid{$name} = $new_fid;
+ }
+ $fid_to_file{$new_fid} = $name;
+ $pending_fids[$fid] = [$new_fid, $new_eval_fid];
+ },
+ SUB_INFO => sub {
+ my (undef, $fid, $first_line, $last_line, $name) = @_;
+ my $output_fid;
+ if ($name =~ $sub_is_anon_in_eval) {
+ confess("No mapping for $fid") unless defined $fids{$fid};
+ $output_fid = $fids{$fid};
+ $seen_subs{"$output_fid,$name"} ||
= "$first_line,$last_line";
+ } else {
+ confess("No mapping for $fid") unless defined
$fids_folded{$fid};
+ my $folded = $fids_folded{$fid};
+ my $seen = $seen_subs{"$folded,$name"};
+ if (defined $seen && $seen ne "$first_line,$last_line") {
+ # Warn that we are not folding
+
+ # Carry on, and output a SUB_INFO block for this fid
+ $output_fid = $fid;
+ } else {
+ # This subroutine has be (re)defined in two distinct
+ # evals, but appears to be identical. So for this lines
+ # range in the second eval, treat profiling data as if
it
+ # came from the fid of the first eval, so that all
calls
+ # to the sub are collated.
+
+ # Have to use the mapped fid as the key to this hash,
as
+ # only the mapped fids are are unique
+ my $mapped_fid = $fids{$fid};
+ $map_range{$mapped_fid}[$_] = $folded
+ for $first_line .. $last_line;
+
+ return if defined $seen;
+
+ $seen_subs{"$folded,$name"} = "$first_line,$last_line";
+ $output_fid = $folded;
+ }
+ }
+ $pending_subs{"$fid,$first_line,$last_line,$name"} =
$output_fid;
+ }
}});
print "Re-reading $input...\n" if $opt_verbose;
@@ -302,35 +302,35 @@
foreach my $fid_line (sort keys %callers) {
my ($fid, $line) = split ',', $fid_line;
foreach my $called (sort keys %{$callers{$fid_line}}) {
- foreach my $caller (sort keys %{$callers{$fid_line}{$called}}) {
- my $sum = $callers{$fid_line}{$called}{$caller};
- $out->write_sub_callers($fid, $line, $caller, $sum->{count},
- @{$sum}{qw(incl excl reci)},
- $sum->{depth}, $called);
- }
+ foreach my $caller (sort keys %{$callers{$fid_line}{$called}}) {
+ my $sum = $callers{$fid_line}{$called}{$caller};
+ $out->write_sub_callers($fid, $line, $caller, $sum->{count},
+ @{$sum}{qw(incl excl reci)},
+ $sum->{depth}, $called);
+ }
}
}
foreach my $key (sort grep {!$identical{$_}} keys %attributes) {
my @values = @{$attributes{$key}};
if ($key eq 'basetime') {
- my $value = min(@values);
- $out->write_attribute($key, $value);
+ my $value = min(@values);
+ $out->write_attribute($key, $value);
} elsif ($key eq 'application') {
- my %counts;
- $counts{$_}++ foreach @values;
- my @grouped;
- foreach my $prog (sort keys %counts) {
- my $count = $counts{$prog};
- push @grouped, $prog;
+ my %counts;
+ $counts{$_}++ foreach @values;
+ my @grouped;
+ foreach my $prog (sort keys %counts) {
+ my $count = $counts{$prog};
+ push @grouped, $prog;
$grouped[-1] .= " ($count runs)" if $count > 1;
- }
- my $last = pop @grouped;
- my $value = @grouped ? join (', ', @grouped) . " and $last" : $last;
- $out->write_attribute($key, $value);
+ }
+ my $last = pop @grouped;
+ my $value = @grouped ? join (', ', @grouped) . " and $last" :
$last;
+ $out->write_attribute($key, $value);
} else {
- warn "Unknown attribute $key\n";
- $out->write_attribute($key, $_) foreach @values;
+ warn "Unknown attribute $key\n";
+ $out->write_attribute($key, $_) foreach @values;
}
}
@@ -375,3 +375,4 @@
let us know at L<http://groups.google.com/group/develnytprof-dev> - thanks!
=cut
+# vim:ts=8:sw=4:et
--
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]
