DProf fixes

Message-ID: <16136.22456.99575.573777@ix.netsoft.ro>

p4raw-id: //depot/perl@20034

3 files changed, 77 insertions, 15 deletions

diff --git a/ext/Devel/DProf/DProf.pm b/ext/Devel/DProf/DProf.pm
index 15fc93a34b..95fcfc253d 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<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>>.
 
diff --git a/ext/Devel/DProf/DProf.t b/ext/Devel/DProf/DProf.t
index ac66fb3dff..3488bc8899 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 caa07293c1..304b56ed4e 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);