From: Radu Greab Date: Sun, 6 Jul 2003 20:09:12 +0000 (+0300) Subject: DProf fixes X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7619c85e4dd9a96a05fc0fc72ace9eb2b9f1bc6f;p=p5sagit%2Fp5-mst-13.2.git DProf fixes Message-ID: <16136.22456.99575.573777@ix.netsoft.ro> p4raw-id: //depot/perl@20034 --- diff --git a/MANIFEST b/MANIFEST index 7b937b8..6b8f765 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2541,6 +2541,10 @@ t/lib/dprof/test5_t Perl code profiler tests 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 diff --git a/ext/Devel/DProf/DProf.pm b/ext/Devel/DProf/DProf.pm index 15fc93a..95fcfc2 100644 --- a/ext/Devel/DProf/DProf.pm +++ b/ext/Devel/DProf/DProf.pm @@ -154,6 +154,24 @@ from this subroutine. Note that the first assignment above does not change the numeric slot (it will I 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 for more details. + Mail bug reports and feature requests to the perl5-porters mailing list at Fperl5-porters@perl.orgE>. diff --git a/ext/Devel/DProf/DProf.t b/ext/Devel/DProf/DProf.t index ac66fb3..3488bc8 100644 --- a/ext/Devel/DProf/DProf.t +++ b/ext/Devel/DProf/DProf.t @@ -73,7 +73,7 @@ sub verify { $| = 1; -print "1..18\n"; +print "1..20\n"; while( @tests ){ $test = shift @tests; $test =~ s/\.$// if $^O eq 'VMS'; diff --git a/ext/Devel/DProf/DProf.xs b/ext/Devel/DProf/DProf.xs index caa0729..304b56e 100644 --- a/ext/Devel/DProf/DProf.xs +++ b/ext/Devel/DProf/DProf.xs @@ -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 @@ typedef struct { 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 @@ prof_state_t g_prof_state; #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 @@ prof_dump_until(pTHX_ long ix) } 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 @@ prof_mark(pTHX_ opcode ptype) 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 @@ XS(XS_DB_sub) /* 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 @@ XS(XS_DB_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--; } @@ -693,6 +736,7 @@ BOOT: 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); diff --git a/perl.c b/perl.c index bf707c0..ba112a2 100644 --- a/perl.c +++ b/perl.c @@ -3483,17 +3483,17 @@ Perl_init_debugger(pTHX) 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); diff --git a/pod/perldiag.pod b/pod/perldiag.pod index b52404e..30ea1ff 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -2656,6 +2656,13 @@ there are in the savestack. (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 diff --git a/pod/perltodo.pod b/pod/perltodo.pod index 1b5db11..e434a1d 100644 --- a/pod/perltodo.pod +++ b/pod/perltodo.pod @@ -580,6 +580,13 @@ Should taint be stopped from affecting control flow, if ($tainted)? 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. diff --git a/pod/perlvar.pod b/pod/perlvar.pod index baa0d82..4ba6fcf 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -1078,6 +1078,10 @@ Provide informative "file" names for evals based on the place they were compiled 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 diff --git a/pp_ctl.c b/pp_ctl.c index 242253b..55ec3c3 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2334,7 +2334,10 @@ PP(pp_goto) 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); diff --git a/t/lib/dprof/test7_t b/t/lib/dprof/test7_t new file mode 100644 index 0000000..56dbfd3 --- /dev/null +++ b/t/lib/dprof/test7_t @@ -0,0 +1,9 @@ +BEGIN { + print "in BEGIN\n"; +} + +sub foo { + print "in sub foo\n"; +} + +foo(); diff --git a/t/lib/dprof/test7_v b/t/lib/dprof/test7_v new file mode 100644 index 0000000..1d19fe5 --- /dev/null +++ b/t/lib/dprof/test7_v @@ -0,0 +1,10 @@ +# perl + +use V; + +dprofpp( '-T' ); +$expected = +qq{main::BEGIN +main::foo +}; +report 19, sub { $expected eq $results }; diff --git a/t/lib/dprof/test8_t b/t/lib/dprof/test8_t new file mode 100644 index 0000000..915a7f7 --- /dev/null +++ b/t/lib/dprof/test8_t @@ -0,0 +1,7 @@ +sub foo { + print "in sub foo\n"; +} + +foo(); +$^P -= 0x40; +foo(); diff --git a/t/lib/dprof/test8_v b/t/lib/dprof/test8_v new file mode 100644 index 0000000..a53758b --- /dev/null +++ b/t/lib/dprof/test8_v @@ -0,0 +1,10 @@ +# perl + +use V; + +dprofpp( '-t' ); +$expected = +qq{main::foo (2x) +}; + +report 20, sub { $expected eq $results };