Revision: 1152
Author: [email protected]
Date: Mon Mar 8 01:50:46 2010
Log: Allow the callback to load_profile_data_from_file() to also be a hash
reference. For a hash reference, the tag name is looked up, with the value
being a callback subroutine to dispatch to. If there is no entry for the
tag,
a lookup is made with an empty string key for a default subroutine. If there
is no default, then no callback is made for that tag.
Convert nytprofmerge to use this approach. This reduces its run time by
about
30%
Internally, in load_profile_to_callback() iterate over the hash when setting
up the state, converting it to an array of callback functions. This avoids
all hash lookups at execution time.
Behaviour for a code reference is unchanged.
http://code.google.com/p/perl-devel-nytprof/source/detail?r=1152
Modified:
/trunk/NYTProf.xs
/trunk/bin/nytprofmerge
=======================================
--- /trunk/NYTProf.xs Mon Mar 8 01:50:35 2010
+++ /trunk/NYTProf.xs Mon Mar 8 01:50:46 2010
@@ -3505,7 +3505,7 @@
#ifdef MULTIPLICITY
PerlInterpreter *interp;
#endif
- CV *cb;
+ CV *cb[nytp_tag_max];
SV *cb_args[11]; /* must be large enough for the largest callback
argument list */
SV *tag_names[nytp_tag_max];
SV *input_chunk_seqn_sv;
@@ -4102,6 +4102,9 @@
else
croak("Unknown type %d passed to perl callback", tag);
}
+
+ if (!state->cb[tag])
+ return;
sv_setuv_mg(state->input_chunk_seqn_sv,
state->base_state.input_chunk_seqn);
@@ -4182,7 +4185,7 @@
assert(i <= C_ARRAY_LENGTH(state->cb_args));
PUTBACK;
- call_sv((SV *)state->cb, G_DISCARD);
+ call_sv((SV *)state->cb[tag], G_DISCARD);
}
@@ -4583,20 +4586,35 @@
}
static void
-load_profile_to_callback(pTHX_ NYTP_file in, CV *cb)
+load_profile_to_callback(pTHX_ NYTP_file in, SV *cb)
{
Loader_state_callback state;
int i;
-
- if (SvTYPE(cb) != SVt_PVCV)
- croak("Not a CODE reference");
+ HV *cb_hv = NULL;
+ CV *default_cb = NULL;
+
+ if (SvTYPE(cb) == SVt_PVHV) {
+ /* A default callback is stored with an empty key. */
+ SV **svp;
+
+ cb_hv = (HV *)cb;
+ svp = hv_fetch(cb_hv, "", 0, 0);
+
+ if (svp) {
+ if (!SvROK(*svp) && SvTYPE(SvRV(*svp)) != SVt_PVCV)
+ croak("Default callback is not a CODE reference");
+ default_cb = (CV *)SvRV(*svp);
+ }
+ } else if (SvTYPE(cb) == SVt_PVCV) {
+ default_cb = (CV *) cb;
+ } else
+ croak("Not a CODE or HASH reference");
#ifdef MULTIPLICITY
state.interp = my_perl;
#endif
state.base_state.input_chunk_seqn = 0;
- state.cb = cb;
state.input_chunk_seqn_sv = save_scalar(gv_fetchpv(".", GV_ADD,
SVt_IV));
sv_setuv(state.input_chunk_seqn_sv, 0);
@@ -4612,6 +4630,20 @@
SvTEMP_off(state.tag_names[i]);
} else
state.tag_names[i] = NULL;
+
+ if (cb_hv) {
+ SV **svp = hv_fetch(cb_hv, callback_info[i].description,
+ callback_info[i].len, 0);
+
+ if (svp) {
+ if (!SvROK(*svp) && SvTYPE(SvRV(*svp)) != SVt_PVCV)
+ croak("Callback for %s is not a CODE reference",
+ callback_info[i].description);
+ state.cb[i] = (CV *)SvRV(*svp);
+ } else
+ state.cb[i] = default_cb;
+ } else
+ state.cb[i] = default_cb;
}
for (i = 0; i < C_ARRAY_LENGTH(state.cb_args); i++)
state.cb_args[i] = sv_newmortal();
@@ -4808,7 +4840,7 @@
croak("Failed to open input '%s': %s", file, strerror(errno));
}
if (cb && SvROK(cb)) {
- load_profile_to_callback(aTHX_ in, (CV *)SvRV(cb));
+ load_profile_to_callback(aTHX_ in, SvRV(cb));
RETVAL = newHV(); /* Can we change this to PL_sv_undef? */
} else
RETVAL = load_profile_to_hv(aTHX_ in);
=======================================
--- /trunk/bin/nytprofmerge Mon Mar 8 01:50:40 2010
+++ /trunk/bin/nytprofmerge Mon Mar 8 01:50:46 2010
@@ -88,6 +88,9 @@
my %dispatcher =
(
+ '' => sub {
+ die "Unknown tag '$_[0]' in $input\n";
+ },
VERSION => sub {
my (undef, $major, $minor) = @_;
my $this_version = "$major $minor";
@@ -209,10 +212,9 @@
@pending_fids = ();
%pending_subs = ();
- Devel::NYTProf::Data->new({filename => $input, callback => sub {
- my $tag = shift;
- if($tag eq 'NEW_FID') {
- my ($fid, $eval_fid, $eval_line, $flags, $size, $mtime, $name) = @_;
+ 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
@@ -249,8 +251,9 @@
}
$fid_to_file{$new_fid} = $name;
$pending_fids[$fid] = [$new_fid, $new_eval_fid];
- } elsif ($tag eq 'SUB_INFO') {
- my ($fid, $first_line, $last_line, $name) = @_;
+ },
+ 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};
@@ -289,11 +292,7 @@
}});
print "Re-reading $input...\n" if $opt_verbose;
- Devel::NYTProf::Data->new({filename => $input, callback => sub {
- my $sub = $dispatcher{$_[0]}
- or die "Unknown tag '$_[0]' in $input\n";
- &$sub(@_);
- }});
+ Devel::NYTProf::Data->new({filename => $input, callback =>
\%dispatcher});
}
print "Finalizing...\n" if $opt_verbose;
--
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]
