#define ASSERT(x)
#endif
+static CV *
+db_get_cv(pTHX_ SV *sv)
+{
+ CV *cv;
+
+ if (SvIOK(sv)) { /* if (PERLDB_SUB_NN) { */
+ cv = INT2PTR(CV*,SvIVX(sv));
+ } else {
+ if (SvPOK(sv)) {
+ cv = get_cv(SvPVX_const(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",
- ((GvSTASH(gv) && HvNAME(GvSTASH(gv))) ?
- HvNAME(GvSTASH(gv)) : "(null)"),
+ ((GvSTASH(gv) && HvNAME_get(GvSTASH(gv))) ?
+ HvNAME_get(GvSTASH(gv)) : "(null)"),
GvNAME(gv));
} else {
warn("XS DBsub(unknown) at %x", Sub);
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_get(GvSTASH(gv)) : 0;
+ pname = pname ? pname : (char *) "(null)";
+ gname = GvNAME(gv);
+
+ set_cv_key(aTHX_ cv, pname, gname);
+ svp = hv_fetch(g_cv_hash, SvPVX_const(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);