Change 20034 by [EMAIL PROTECTED] on 2003/07/06 16:46:20
Subject: [PATCH @19834] DProf fixes
From: Radu Greab <[EMAIL PROTECTED]>
Date: Sun, 6 Jul 2003 20:09:12 +0300
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/MANIFEST#1039 edit
... //depot/perl/ext/Devel/DProf/DProf.pm#10 edit
... //depot/perl/ext/Devel/DProf/DProf.t#5 edit
... //depot/perl/ext/Devel/DProf/DProf.xs#32 edit
... //depot/perl/perl.c#505 edit
... //depot/perl/pod/perldiag.pod#351 edit
... //depot/perl/pod/perltodo.pod#74 edit
... //depot/perl/pod/perlvar.pod#128 edit
... //depot/perl/pp_ctl.c#363 edit
... //depot/perl/t/lib/dprof/test7_t#1 add
... //depot/perl/t/lib/dprof/test7_v#1 add
... //depot/perl/t/lib/dprof/test8_t#1 add
... //depot/perl/t/lib/dprof/test8_v#1 add
Differences ...
==== //depot/perl/MANIFEST#1039 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#1038~20031~ Sun Jul 6 09:16:08 2003
+++ perl/MANIFEST Sun Jul 6 09:46:20 2003
@@ -2541,6 +2541,10 @@
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
==== //depot/perl/ext/Devel/DProf/DProf.pm#10 (text) ====
Index: perl/ext/Devel/DProf/DProf.pm
--- perl/ext/Devel/DProf/DProf.pm#9~18526~ Mon Jan 20 15:21:22 2003
+++ perl/ext/Devel/DProf/DProf.pm Sun Jul 6 09:46:20 2003
@@ -154,6 +154,24 @@
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>[EMAIL PROTECTED]<gt>>.
==== //depot/perl/ext/Devel/DProf/DProf.t#5 (text) ====
Index: perl/ext/Devel/DProf/DProf.t
--- perl/ext/Devel/DProf/DProf.t#4~19921~ Tue Jul 1 22:26:33 2003
+++ perl/ext/Devel/DProf/DProf.t Sun Jul 6 09:46:20 2003
@@ -73,7 +73,7 @@
$| = 1;
-print "1..18\n";
+print "1..20\n";
while( @tests ){
$test = shift @tests;
$test =~ s/\.$// if $^O eq 'VMS';
==== //depot/perl/ext/Devel/DProf/DProf.xs#32 (text) ====
Index: perl/ext/Devel/DProf/DProf.xs
--- perl/ext/Devel/DProf/DProf.xs#31~18526~ Mon Jan 20 15:21:22 2003
+++ perl/ext/Devel/DProf/DProf.xs Sun Jul 6 09:46:20 2003
@@ -15,11 +15,30 @@
#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",
@@ -106,7 +125,8 @@
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;
@@ -144,6 +164,7 @@
#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
@@ -295,6 +316,16 @@
}
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;
@@ -336,17 +367,19 @@
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 */
@@ -547,12 +580,14 @@
/* 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);
@@ -561,8 +596,16 @@
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--;
}
@@ -693,6 +736,7 @@
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);
==== //depot/perl/perl.c#505 (text) ====
Index: perl/perl.c
--- perl/perl.c#504~20009~ Sat Jul 5 03:56:55 2003
+++ perl/perl.c Sun Jul 6 09:46:20 2003
@@ -3483,17 +3483,17 @@
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);
==== //depot/perl/pod/perldiag.pod#351 (text) ====
Index: perl/pod/perldiag.pod
--- perl/pod/perldiag.pod#350~19794~ Sun Jun 15 14:01:18 2003
+++ perl/pod/perldiag.pod Sun Jul 6 09:46:20 2003
@@ -2656,6 +2656,13 @@
(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
==== //depot/perl/pod/perltodo.pod#74 (text) ====
Index: perl/pod/perltodo.pod
--- perl/pod/perltodo.pod#73~19433~ Mon May 5 22:12:23 2003
+++ perl/pod/perltodo.pod Sun Jul 6 09:46:20 2003
@@ -580,6 +580,13 @@
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.
==== //depot/perl/pod/perlvar.pod#128 (text) ====
Index: perl/pod/perlvar.pod
--- perl/pod/perlvar.pod#127~20012~ Sat Jul 5 06:46:05 2003
+++ perl/pod/perlvar.pod Sun Jul 6 09:46:20 2003
@@ -1078,6 +1078,10 @@
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
==== //depot/perl/pp_ctl.c#363 (text) ====
Index: perl/pp_ctl.c
--- perl/pp_ctl.c#362~19934~ Wed Jul 2 12:39:11 2003
+++ perl/pp_ctl.c Sun Jul 6 09:46:20 2003
@@ -2334,7 +2334,10 @@
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);
==== //depot/perl/t/lib/dprof/test7_t#1 (text) ====
Index: perl/t/lib/dprof/test7_t
--- /dev/null Tue May 5 13:32:27 1998
+++ perl/t/lib/dprof/test7_t Sun Jul 6 09:46:20 2003
@@ -0,0 +1,9 @@
+BEGIN {
+ print "in BEGIN\n";
+}
+
+sub foo {
+ print "in sub foo\n";
+}
+
+foo();
==== //depot/perl/t/lib/dprof/test7_v#1 (text) ====
Index: perl/t/lib/dprof/test7_v
--- /dev/null Tue May 5 13:32:27 1998
+++ perl/t/lib/dprof/test7_v Sun Jul 6 09:46:20 2003
@@ -0,0 +1,10 @@
+# perl
+
+use V;
+
+dprofpp( '-T' );
+$expected =
+qq{main::BEGIN
+main::foo
+};
+report 19, sub { $expected eq $results };
==== //depot/perl/t/lib/dprof/test8_t#1 (text) ====
Index: perl/t/lib/dprof/test8_t
--- /dev/null Tue May 5 13:32:27 1998
+++ perl/t/lib/dprof/test8_t Sun Jul 6 09:46:20 2003
@@ -0,0 +1,7 @@
+sub foo {
+ print "in sub foo\n";
+}
+
+foo();
+$^P -= 0x40;
+foo();
==== //depot/perl/t/lib/dprof/test8_v#1 (text) ====
Index: perl/t/lib/dprof/test8_v
--- /dev/null Tue May 5 13:32:27 1998
+++ perl/t/lib/dprof/test8_v Sun Jul 6 09:46:20 2003
@@ -0,0 +1,10 @@
+# perl
+
+use V;
+
+dprofpp( '-t' );
+$expected =
+qq{main::foo (2x)
+};
+
+report 20, sub { $expected eq $results };
End of Patch.
