C++ (or C99) sneak attack ("inline" function keyword).

[p5sagit/p5-mst-13.2.git] / ext / Devel / DProf / DProf.xs

diff --git a/ext/Devel/DProf/DProf.xs b/ext/Devel/DProf/DProf.xs
index 78ea3c9..8202142 100644 (file)
--- a/ext/Devel/DProf/DProf.xs
+++ b/ext/Devel/DProf/DProf.xs
@@ -9,11 +9,36 @@
 /* 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(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",
@@ -100,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;
@@ -138,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
@@ -289,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;
@@ -297,7 +334,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);
        }
@@ -309,6 +346,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;
@@ -329,20 +367,23 @@ 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(GvSTASH(gv))) 
+                ? HvNAME(GvSTASH(gv)) 
+                : "(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(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;
@@ -365,6 +406,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;
 
@@ -538,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);
 
@@ -552,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--;
     }
@@ -684,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);