t/lib/dprof/test5_v Perl code profiler tests
t/lib/dprof/test6_t Perl code profiler tests
t/lib/dprof/test6_v Perl code profiler tests
+t/lib/dprof/test7_t Perl code profiler tests
+t/lib/dprof/test7_v Perl code profiler tests
+t/lib/dprof/test8_t Perl code profiler tests
+t/lib/dprof/test8_v Perl code profiler tests
t/lib/dprof/V.pm Perl code profiler tests
t/lib/filter-util.pl See if Filter::Util::Call works
t/lib/Filter/Simple/ExportTest.pm Helper file for Filter::Simple tests
change the numeric slot (it will I<mark> it as invalid, but will not
write over it).
+Another problem is that if a subroutine exits using goto(LABEL),
+last(LABEL) or next(LABEL) then perl may crash or Devel::DProf will die
+with the error:
+
+ panic: Devel::DProf inconsistent subroutine return
+
+For example, this code will break under Devel::DProf:
+
+ sub foo {
+ last FOO;
+ }
+ FOO: {
+ foo();
+ }
+
+A pattern like this is used by Test::More's skip() function, for
+example. See L<perldiag> for more details.
+
Mail bug reports and feature requests to the perl5-porters mailing list at
F<E<lt>perl5-porters@perl.orgE<gt>>.
$| = 1;
-print "1..18\n";
+print "1..20\n";
while( @tests ){
$test = shift @tests;
$test =~ s/\.$// if $^O eq 'VMS';
#define ASSERT(x)
#endif
+static CV *
+db_get_cv(pTHX_ SV *sv)
+{
+ CV *cv;
+
+ if (PERLDB_SUB_NN) {
+ cv = INT2PTR(CV*,SvIVX(sv));
+ } else {
+ if (SvPOK(sv)) {
+ cv = get_cv(SvPVX(sv), TRUE);
+ } else if (SvROK(sv)) {
+ cv = (CV*)SvRV(sv);
+ } else {
+ croak("DProf: don't know what subroutine to profile");
+ }
+ }
+ return cv;
+}
+
#ifdef DBG_SUB
-# define DBG_SUB_NOTIFY(A) dprof_dbg_sub_notify(A)
+# define DBG_SUB_NOTIFY(A) dprof_dbg_sub_notify(aTHX_ A)
void
-dprof_dbg_sub_notify(SV *Sub) {
- CV *cv = INT2PTR(CV*,SvIVX(Sub));
+dprof_dbg_sub_notify(pTHX_ SV *Sub) {
+ CV *cv = db_get_cv(aTHX_ Sub);
GV *gv = cv ? CvGV(cv) : NULL;
if (cv && gv) {
warn("XS DBsub(%s::%s)\n",
PROFANY* profstack;
int profstack_max;
int profstack_ix;
- HV* cv_hash;
+ HV* cv_hash; /* cache of CV to identifier mappings */
+ SV* key_hash; /* key for cv_hash */
U32 total;
U32 lastid;
U32 default_perldb;
#define g_profstack_max g_prof_state.profstack_max
#define g_profstack_ix g_prof_state.profstack_ix
#define g_cv_hash g_prof_state.cv_hash
+#define g_key_hash g_prof_state.key_hash
#define g_total g_prof_state.total
#define g_lastid g_prof_state.lastid
#define g_default_perldb g_prof_state.default_perldb
}
static void
+set_cv_key(pTHX_ CV *cv, char *pname, char *gname)
+{
+ SvGROW(g_key_hash, sizeof(CV*) + strlen(pname) + strlen(gname) + 3);
+ sv_setpvn(g_key_hash, (char*)&cv, sizeof(CV*));
+ sv_catpv(g_key_hash, pname);
+ sv_catpv(g_key_hash, "::");
+ sv_catpv(g_key_hash, gname);
+}
+
+static void
prof_mark(pTHX_ opcode ptype)
{
struct tms t;
SV **svp;
char *gname, *pname;
CV *cv;
+ GV *gv;
- cv = INT2PTR(CV*,SvIVX(Sub));
- svp = hv_fetch(g_cv_hash, (char*)&cv, sizeof(CV*), TRUE);
+ cv = db_get_cv(aTHX_ Sub);
+ gv = CvGV(cv);
+ pname = ((GvSTASH(gv) && HvNAME(GvSTASH(gv)))
+ ? HvNAME(GvSTASH(gv))
+ : "(null)");
+ gname = GvNAME(gv);
+
+ set_cv_key(aTHX_ cv, pname, gname);
+ svp = hv_fetch(g_cv_hash, SvPVX(g_key_hash), SvCUR(g_key_hash), TRUE);
if (!SvOK(*svp)) {
- GV *gv = CvGV(cv);
-
sv_setiv(*svp, id = ++g_lastid);
- pname = ((GvSTASH(gv) && HvNAME(GvSTASH(gv)))
- ? HvNAME(GvSTASH(gv))
- : "(null)");
- gname = GvNAME(gv);
if (CvXSUB(cv) == XS_Devel__DProf_END)
return;
if (g_SAVE_STACK) { /* Store it for later recording -JH */
/* profile only the interpreter that loaded us */
if (g_THX != aTHX) {
PUSHMARK(ORIGMARK);
- perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME_V | G_NODEBUG);
+ perl_call_sv((SV*)db_get_cv(aTHX_ Sub), GIMME_V | G_NODEBUG);
}
else
#endif
{
HV *oldstash = PL_curstash;
+ I32 old_scopestack_ix = PL_scopestack_ix;
+ I32 old_cxstack_ix = cxstack_ix;
DBG_SUB_NOTIFY(Sub);
prof_mark(aTHX_ OP_ENTERSUB);
PUSHMARK(ORIGMARK);
- perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME_V | G_NODEBUG);
+ perl_call_sv((SV*)db_get_cv(aTHX_ Sub), GIMME_V | G_NODEBUG);
PL_curstash = oldstash;
+
+ /* Make sure we are on the same context and scope as before the call
+ * to the sub. If the called sub was exited via a goto, next or
+ * last then this will try to croak(), however perl may still crash
+ * with a segfault. */
+ if (PL_scopestack_ix != old_scopestack_ix || cxstack_ix != old_cxstack_ix)
+ croak("panic: Devel::DProf inconsistent subroutine return");
+
prof_mark(aTHX_ OP_LEAVESUB);
g_depth--;
}
g_default_perldb = PERLDBf_NONAME | PERLDBf_SUB | PERLDBf_GOTO;
g_cv_hash = newHV();
+ g_key_hash = newSV(256);
g_prof_pid = (int)getpid();
New(0, g_profstack, g_profstack_max, PROFANY);
HV *ostash = PL_curstash;
PL_curstash = PL_debstash;
- PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
+ PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
AvREAL_off(PL_dbargs);
- PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
- PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
- PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
+ PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
+ PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
+ PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
- PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
+ PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsingle, 0);
- PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
+ PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBtrace, 0);
- PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
+ PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsignal, 0);
PL_DBassertion = GvSV((gv_fetchpv("assertion", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBassertion, 0);
(P) Failed an internal consistency check while trying to reset a weak
reference.
+=item panic: Devel::DProf inconsistent subroutine return
+
+(P) Devel::DProf called a subroutine that exited using goto(LABEL),
+last(LABEL) or next(LABEL). Leaving that way a subroutine called from
+an XSUB will lead very probably to a crash of the interpreter. This is
+a bug that will hopefully one day get fixed.
+
=item panic: die %s
(P) We popped the context stack to an eval context, and then discovered
Should tainted symbolic method calls and subref calls be stopped?
(Look at Ruby's $SAFE levels for inspiration?)
+=head2 Perform correctly when XSUBs call subroutines that exit via goto(LABEL) and friends
+
+If an XSUB calls a subroutine that exits using goto(LABEL),
+last(LABEL) or next(LABEL), then the interpreter will very probably crash
+with a segfault because the execution resumes in the XSUB instead of
+never returning there.
+
=head1 Vague ideas
Ideas which have been discussed, and which may or may not happen.
Provide informative names to anonymous subroutines based on the place they
were compiled.
+=item 0x400
+
+Debug assertion subroutines enter/exit.
+
=back
Some bits may be relevant at compile-time only, some at
CV *gotocv;
if (PERLDB_SUB_NN) {
- SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
+ (void)SvUPGRADE(sv, SVt_PVIV);
+ (void)SvIOK_on(sv);
+ SAVEIV(SvIVX(sv));
+ SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
} else {
save_item(sv);
gv_efullname3(sv, CvGV(cv), Nullch);
--- /dev/null
+BEGIN {
+ print "in BEGIN\n";
+}
+
+sub foo {
+ print "in sub foo\n";
+}
+
+foo();
--- /dev/null
+# perl
+
+use V;
+
+dprofpp( '-T' );
+$expected =
+qq{main::BEGIN
+main::foo
+};
+report 19, sub { $expected eq $results };
--- /dev/null
+sub foo {
+ print "in sub foo\n";
+}
+
+foo();
+$^P -= 0x40;
+foo();
--- /dev/null
+# perl
+
+use V;
+
+dprofpp( '-t' );
+$expected =
+qq{main::foo (2x)
+};
+
+report 20, sub { $expected eq $results };
projects / p5sagit/p5-mst-13.2.git / commitdiff