In perl.git, the branch davem/post-5.12 has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/1c98cc53150c48606faf09909b3bb3a4ebdd329f?hp=099be4f1d597471eb719c9a344b7c1b55e11ba24>
- Log -----------------------------------------------------------------
commit 1c98cc53150c48606faf09909b3bb3a4ebdd329f
Author: David Mitchell <da...@iabyn.com>
Date: Tue Mar 30 20:26:31 2010 +0100
improve -Dl debugging output
In particular, distinguish between scope and context stack push/pops,
show depth of JUMPENV stack, and show STACKINFO push/pops
-----------------------------------------------------------------------
Summary of changes:
cop.h | 82 ++++++++++++++++++++++++++++++++++++++++++++++----------------
perl.h | 6 +++-
pp_ctl.c | 19 +++++++-------
scope.c | 2 +
4 files changed, 76 insertions(+), 33 deletions(-)
diff --git a/cop.h b/cop.h
index 13ce794..2d0a459 100644
--- a/cop.h
+++ b/cop.h
@@ -14,11 +14,12 @@
*/
/* A jmpenv packages the state required to perform a proper non-local jump.
- * Note that there is a start_env initialized when perl starts, and top_env
- * points to this initially, so top_env should always be non-null.
+ * Note that there is a PL_start_env initialized when perl starts, and
+ * PL_top_env points to this initially, so PL_top_env should always be
+ * non-null.
*
- * Existence of a non-null top_env->je_prev implies it is valid to call
- * longjmp() at that runlevel (we make sure start_env.je_prev is always
+ * Existence of a non-null PL_top_env->je_prev implies it is valid to call
+ * longjmp() at that runlevel (we make sure PL_start_env.je_prev is always
* null to ensure this).
*
* je_mustcatch, when set at any runlevel to TRUE, means eval ops must
@@ -99,9 +100,12 @@ typedef struct jmpenv JMPENV;
#define JMPENV_PUSH(v) \
STMT_START { \
- DEBUG_l(Perl_deb(aTHX_ "Setting up jumplevel %p, was %p at %s:%d\n",
\
- (void*)&cur_env, (void*)PL_top_env,
\
- __FILE__, __LINE__));
\
+ DEBUG_l({ \
+ int i = 0; JMPENV *p = PL_top_env; \
+ while (p) { i++; p = p->je_prev; } \
+ Perl_deb(aTHX_ "push JUMPLEVEL %d (now %p, was %p) at %s:%d\n",\
+ i, (void*)&cur_env, (void*)PL_top_env, \
+ __FILE__, __LINE__);}) \
cur_env.je_prev = PL_top_env; \
OP_REG_TO_MEM; \
cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf,
SCOPE_SAVES_SIGNAL_MASK); \
@@ -113,15 +117,24 @@ typedef struct jmpenv JMPENV;
#define JMPENV_POP \
STMT_START { \
- DEBUG_l(Perl_deb(aTHX_ "popping jumplevel was %p, now %p at %s:%d\n",
\
- (void*)PL_top_env, (void*)cur_env.je_prev,
\
- __FILE__, __LINE__));
\
+ DEBUG_l({ \
+ int i = -1; JMPENV *p = PL_top_env; \
+ while (p) { i++; p = p->je_prev; } \
+ Perl_deb(aTHX_ "pop JUMPLEVEL %d (now %p, was %p) at %s:%d\n",\
+ i, (void*)cur_env.je_prev, (void*)PL_top_env, \
+ __FILE__, __LINE__);}) \
assert(PL_top_env == &cur_env); \
PL_top_env = cur_env.je_prev; \
} STMT_END
#define JMPENV_JUMP(v) \
STMT_START { \
+ DEBUG_l({ \
+ int i = -1; JMPENV *p = PL_top_env; \
+ while (p) { i++; p = p->je_prev; } \
+ Perl_deb(aTHX_ "JUMP JUMPLEVEL %d (%p) at %s:%d\n", \
+ i, (void*)PL_top_env, \
+ __FILE__, __LINE__);}) \
OP_REG_TO_MEM; \
if (PL_top_env->je_prev) \
PerlProc_longjmp(PL_top_env->je_buf, (v)); \
@@ -132,7 +145,15 @@ typedef struct jmpenv JMPENV;
} STMT_END
#define CATCH_GET (PL_top_env->je_mustcatch)
-#define CATCH_SET(v) (PL_top_env->je_mustcatch = (v))
+#define CATCH_SET(v) \
+ STMT_START { \
+ DEBUG_l( \
+ Perl_deb(aTHX_ \
+ "JUMPLEVEL set catch %d => %d (for %p) at %s:%d\n", \
+ PL_top_env->je_mustcatch, v, (void*)PL_top_env, \
+ __FILE__, __LINE__);) \
+ PL_top_env->je_mustcatch = (v); \
+ } STMT_END
#include "mydtrace.h"
@@ -550,6 +571,16 @@ struct block {
#define blk_loop cx_u.cx_blk.blk_u.blku_loop
#define blk_givwhen cx_u.cx_blk.blk_u.blku_givwhen
+#define DEBUG_CX(action) \
+ DEBUG_l(WITH_THX( \
+ Perl_deb(aTHX_ "CX %ld %s %s (scope %ld,%ld) at %s:%d\n", \
+ (long)cxstack_ix, \
+ action, \
+ PL_block_type[CxTYPE(&cxstack[cxstack_ix])], \
+ (long)PL_scopestack_ix, \
+ (long)(cxstack[cxstack_ix].blk_oldscopesp), \
+ __FILE__, __LINE__)));
+
/* Enter a block. */
#define PUSHBLOCK(cx,t,sp) CXINC, cx = &cxstack[cxstack_ix], \
cx->cx_type = t, \
@@ -559,28 +590,27 @@ struct block {
cx->blk_oldscopesp = PL_scopestack_ix, \
cx->blk_oldpm = PL_curpm, \
cx->blk_gimme = (U8)gimme; \
- DEBUG_l( PerlIO_printf(Perl_debug_log, "Entering block %ld, type %s\n",
\
- (long)cxstack_ix, PL_block_type[CxTYPE(cx)]); )
+ DEBUG_CX("PUSH");
/* Exit a block (RETURN and LAST). */
-#define POPBLOCK(cx,pm) cx = &cxstack[cxstack_ix--], \
+#define POPBLOCK(cx,pm)
\
+ DEBUG_CX("POP"); \
+ cx = &cxstack[cxstack_ix--], \
newsp = PL_stack_base + cx->blk_oldsp, \
PL_curcop = cx->blk_oldcop, \
PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \
PL_scopestack_ix = cx->blk_oldscopesp, \
pm = cx->blk_oldpm, \
- gimme = cx->blk_gimme; \
- DEBUG_SCOPE("POPBLOCK"); \
- DEBUG_l( PerlIO_printf(Perl_debug_log, "Leaving block %ld, type %s\n",
\
- (long)cxstack_ix+1,PL_block_type[CxTYPE(cx)]); )
+ gimme = cx->blk_gimme;
/* Continue a block elsewhere (NEXT and REDO). */
-#define TOPBLOCK(cx) cx = &cxstack[cxstack_ix], \
+#define TOPBLOCK(cx) \
+ DEBUG_CX("TOP"); \
+ cx = &cxstack[cxstack_ix], \
PL_stack_sp = PL_stack_base + cx->blk_oldsp, \
PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \
PL_scopestack_ix = cx->blk_oldscopesp, \
- PL_curpm = cx->blk_oldpm; \
- DEBUG_SCOPE("TOPBLOCK");
+ PL_curpm = cx->blk_oldpm;
/* substitution context */
struct subst {
@@ -809,6 +839,11 @@ typedef struct stackinfo PERL_SI;
#define PUSHSTACKi(type) \
STMT_START { \
PERL_SI *next = PL_curstackinfo->si_next; \
+ DEBUG_l({ \
+ int i = 0; PERL_SI *p = PL_curstackinfo; \
+ while (p) { i++; p = p->si_prev; } \
+ Perl_deb(aTHX_ "push STACKINFO %d at %s:%d\n", \
+ i, __FILE__, __LINE__);}) \
if (!next) { \
next = new_stackinfo(32, 2048/sizeof(PERL_CONTEXT) - 1); \
next->si_prev = PL_curstackinfo; \
@@ -830,6 +865,11 @@ typedef struct stackinfo PERL_SI;
STMT_START { \
dSP; \
PERL_SI * const prev = PL_curstackinfo->si_prev; \
+ DEBUG_l({ \
+ int i = -1; PERL_SI *p = PL_curstackinfo; \
+ while (p) { i++; p = p->si_prev; } \
+ Perl_deb(aTHX_ "pop STACKINFO %d at %s:%d\n", \
+ i, __FILE__, __LINE__);}) \
if (!prev) { \
PerlIO_printf(Perl_error_log, "panic: POPSTACK\n"); \
my_exit(1); \
diff --git a/perl.h b/perl.h
index 5988e78..960ba1a 100644
--- a/perl.h
+++ b/perl.h
@@ -3818,8 +3818,10 @@ Gid_t getegid (void);
#define DEBUG_SCOPE(where) \
- DEBUG_l(WITH_THR(Perl_deb(aTHX_ "%s scope %ld at %s:%d\n", \
- where, (long)PL_scopestack_ix, __FILE__, __LINE__)));
+ DEBUG_l(WITH_THR( \
+ Perl_deb(aTHX_ "%s scope %ld (savestack=%ld) at %s:%d\n", \
+ where, (long)PL_scopestack_ix, (long)PL_savestack_ix, \
+ __FILE__, __LINE__)));
diff --git a/pp_ctl.c b/pp_ctl.c
index a35cd43..80c7b22 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1339,11 +1339,11 @@ S_dopoptolabel(pTHX_ const char *label)
{
const char *cx_label = CxLABEL(cx);
if (!cx_label || strNE(label, cx_label) ) {
- DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
+ DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld
%s)\n",
(long)i, cx_label));
continue;
}
- DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
+ DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld
%s)\n", (long)i, label));
return i;
}
}
@@ -1412,7 +1412,7 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32
startingblock)
case CXt_EVAL:
case CXt_SUB:
case CXt_FORMAT:
- DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n",
(long)i));
return i;
}
}
@@ -1430,7 +1430,7 @@ S_dopoptoeval(pTHX_ I32 startingblock)
default:
continue;
case CXt_EVAL:
- DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n",
(long)i));
return i;
}
}
@@ -1459,7 +1459,7 @@ S_dopoptoloop(pTHX_ I32 startingblock)
case CXt_LOOP_LAZYSV:
case CXt_LOOP_FOR:
case CXt_LOOP_PLAIN:
- DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n",
(long)i));
return i;
}
}
@@ -1477,7 +1477,7 @@ S_dopoptogiven(pTHX_ I32 startingblock)
default:
continue;
case CXt_GIVEN:
- DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at
cx=%ld)\n", (long)i));
return i;
case CXt_LOOP_PLAIN:
assert(!CxFOREACHDEF(cx));
@@ -1486,7 +1486,7 @@ S_dopoptogiven(pTHX_ I32 startingblock)
case CXt_LOOP_LAZYSV:
case CXt_LOOP_FOR:
if (CxFOREACHDEF(cx)) {
- DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at
cx=%ld)\n", (long)i));
return i;
}
}
@@ -1505,7 +1505,7 @@ S_dopoptowhen(pTHX_ I32 startingblock)
default:
continue;
case CXt_WHEN:
- DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n",
(long)i));
return i;
}
}
@@ -1521,8 +1521,7 @@ Perl_dounwind(pTHX_ I32 cxix)
while (cxstack_ix > cxix) {
SV *sv;
register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
- DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
- (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
+ DEBUG_CX("UNWIND"); \
/* Note: we don't need to restore the base context info till the end. */
switch (CxTYPE(cx)) {
case CXt_SUBST:
diff --git a/scope.c b/scope.c
index ed4c835..414f5b5 100644
--- a/scope.c
+++ b/scope.c
@@ -694,6 +694,8 @@ Perl_leave_scope(pTHX_ I32 base)
if (base < -1)
Perl_croak(aTHX_ "panic: corrupt saved stack index");
+ DEBUG_l(Perl_deb(aTHX_ "savestack: releasing items %ld -> %ld\n",
+ (long)PL_savestack_ix, (long)base));
while (PL_savestack_ix > base) {
TAINT_NOT;
--
Perl5 Master Repository
