diff options
| -rw-r--r-- | cop.h | 82 | ||||
| -rw-r--r-- | perl.h | 6 | ||||
| -rw-r--r-- | pp_ctl.c | 19 | ||||
| -rw-r--r-- | scope.c | 2 |
4 files changed, 76 insertions, 33 deletions
@@ -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); \ @@ -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__))); @@ -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: @@ -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; |