X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FDevel%2FDProf%2FDProf.xs;h=02396e94b6aa291c94d2ccf4a035fa0e590a5081;hb=5b4563c8796d609e1b00a7e3af7630b7fee611ae;hp=c34a36618112e4c722d8a77a98029dc2a54cc3f1;hpb=c6c619a96fa11b09bef26d0c724b6cfd0bdbb34b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/Devel/DProf/DProf.xs b/ext/Devel/DProf/DProf.xs index c34a366..02396e9 100644 --- a/ext/Devel/DProf/DProf.xs +++ b/ext/Devel/DProf/DProf.xs @@ -3,15 +3,57 @@ #include "perl.h" #include "XSUB.h" +/* define DBG_SUB to cause a warning on each subroutine entry. */ /*#define DBG_SUB 1 */ -/*#define DBG_TIMER 1 */ + +/* define DBG_TIMER to cause a warning when the timer is turned on and off. */ +/*#define DBG_TIMER 1 */ + +#ifdef DEBUGGING +#define ASSERT(x) assert(x) +#else +#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,B) warn(A, B) +# define DBG_SUB_NOTIFY(A) dprof_dbg_sub_notify(aTHX_ A) +void +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_get(GvSTASH(gv))) ? + HvNAME_get(GvSTASH(gv)) : "(null)"), + GvNAME(gv)); + } else { + warn("XS DBsub(unknown) at %x", Sub); + } +} #else -# define DBG_SUB_NOTIFY(A,B) /* nothing */ +# define DBG_SUB_NOTIFY(A) /* nothing */ #endif + #ifdef DBG_TIMER # define DBG_TIMER_NOTIFY(A) warn(A) #else @@ -67,7 +109,7 @@ typedef struct { U32 dprof_ticks; char* out_file_name; /* output file (defaults to tmon.out) */ PerlIO* fp; /* pointer to tmon.out file */ - long TIMES_LOCATION; /* Where in the file to store the time totals */ + Off_t TIMES_LOCATION; /* Where in the file to store the time totals */ int SAVE_STACK; /* How much data to buffer until end of run */ int prof_pid; /* pid of profiled process */ struct tms prof_start; @@ -83,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; @@ -93,9 +136,7 @@ typedef struct { long long start_cnt; #endif #ifdef PERL_IMPLICIT_CONTEXT -# define register - pTHX; -# undef register + PerlInterpreter *my_perl; #endif } prof_state_t; @@ -121,12 +162,13 @@ 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 #define g_depth g_prof_state.depth #ifdef PERL_IMPLICIT_CONTEXT -# define g_THX g_prof_state.aTHX +# define g_THX g_prof_state.my_perl #endif #ifdef OS2 # define g_frequ g_prof_state.frequ @@ -139,7 +181,6 @@ dprof_times(pTHX_ struct tms *t) #ifdef OS2 ULONG rc; QWORD cnt; - STRLEN n_a; if (!g_frequ) { if (CheckOSError(DosTmrQueryFreq(&g_frequ))) @@ -148,7 +189,7 @@ dprof_times(pTHX_ struct tms *t) g_frequ = g_frequ/DPROF_HZ; /* count per tick */ if (CheckOSError(DosTmrQueryTime(&cnt))) croak("DosTmrQueryTime: %s", - SvPV(perl_get_sv("!",TRUE), n_a)); + SvPV_nolen_const(perl_get_sv("!",TRUE))); g_start_cnt = toLongLong(cnt); } @@ -272,6 +313,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; @@ -280,7 +331,7 @@ prof_mark(pTHX_ opcode ptype) SV *Sub = GvSV(PL_DBsub); /* name of current sub */ if (g_SAVE_STACK) { - if (g_profstack_ix + 5 > g_profstack_max) { + if (g_profstack_ix + 10 > g_profstack_max) { g_profstack_max = g_profstack_max * 3 / 2; Renew(g_profstack, g_profstack_max, PROFANY); } @@ -292,6 +343,7 @@ prof_mark(pTHX_ opcode ptype) sdelta = t.tms_stime - g_otms_stime; if (rdelta || udelta || sdelta) { if (g_SAVE_STACK) { + ASSERT(g_profstack_ix + 4 <= g_profstack_max); g_profstack[g_profstack_ix++].ptype = OP_TIME; g_profstack[g_profstack_ix++].tms_utime = udelta; g_profstack[g_profstack_ix++].tms_stime = sdelta; @@ -312,20 +364,22 @@ prof_mark(pTHX_ opcode ptype) SV **svp; char *gname, *pname; CV *cv; + GV *gv; + + 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); - cv = INT2PTR(CV*,SvIVX(Sub)); - svp = hv_fetch(g_cv_hash, (char*)&cv, sizeof(CV*), TRUE); + 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 */ + ASSERT(g_profstack_ix + 4 <= g_profstack_max); g_profstack[g_profstack_ix++].ptype = OP_GV; g_profstack[g_profstack_ix++].id = id; g_profstack[g_profstack_ix++].name = pname; @@ -348,6 +402,7 @@ prof_mark(pTHX_ opcode ptype) g_total++; if (g_SAVE_STACK) { /* Store it for later recording -JH */ + ASSERT(g_profstack_ix + 2 <= g_profstack_max); g_profstack[g_profstack_ix++].ptype = ptype; g_profstack[g_profstack_ix++].id = id; @@ -521,22 +576,32 @@ 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 | 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("XS DBsub(%s)\n", SvPV_nolen(Sub)); + DBG_SUB_NOTIFY(Sub); SAVEDESTRUCTOR_X(check_depth, INT2PTR(void*,g_depth)); g_depth++; prof_mark(aTHX_ OP_ENTERSUB); PUSHMARK(ORIGMARK); - perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | 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--; } @@ -568,7 +633,7 @@ XS(XS_DB_goto) HV *oldstash = PL_curstash; SV *Sub = GvSV(PL_DBsub); /* name of current sub */ /* SP -= items; added by xsubpp */ - DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub)); + DBG_SUB_NOTIFY(Sub); sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */ @@ -576,7 +641,7 @@ XS(XS_DB_goto) PUSHMARK(ORIGMARK); PL_curstash = PL_debstash; /* To disable debugging of perl_call_sv */ - perl_call_sv(Sub, GIMME); + perl_call_sv(Sub, GIMME_V); PL_curstash = oldstash; prof_mark(aTHX_ OP_LEAVESUB); @@ -632,7 +697,7 @@ BOOT: * while we do this. */ { - I32 warn_tmp = PL_dowarn; + bool warn_tmp = PL_dowarn; PL_dowarn = 0; newXS("DB::sub", XS_DB_sub, file); newXS("DB::goto", XS_DB_goto, file); @@ -667,9 +732,10 @@ 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); + Newx(g_profstack, g_profstack_max, PROFANY); prof_recordheader(aTHX); DBG_TIMER_NOTIFY("Profiler timer is on.\n"); g_orealtime = g_rprof_start = Times(&g_prof_start);