improve -Dl debugging output

In particular, distinguish between scope and context stack push/pops,
show depth of JUMPENV stack, and show STACKINFO push/pops

4 files changed, 76 insertions, 33 deletions

diff --git a/cop.h b/cop.h
index 13ce794ce2..2d0a4593ec 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 5988e7845a..960ba1ae37 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 a35cd43a2b..80c7b221d7 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 ed4c835de9..414f5b5225 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;