diff options
| -rw-r--r-- | embedvar.h | 2 | ||||
| -rw-r--r-- | intrpvar.h | 3 | ||||
| -rw-r--r-- | perl.c | 3 | ||||
| -rw-r--r-- | perlapi.h | 2 | ||||
| -rw-r--r-- | pp.c | 16 | ||||
| -rw-r--r-- | pp_ctl.c | 82 | ||||
| -rw-r--r-- | pp_hot.c | 40 | ||||
| -rw-r--r-- | pp_sys.c | 34 | ||||
| -rw-r--r-- | scope.c | 6 | ||||
| -rw-r--r-- | scope.h | 28 |
10 files changed, 130 insertions, 86 deletions
diff --git a/embedvar.h b/embedvar.h index 0ed7d38dd9..e805a79822 100644 --- a/embedvar.h +++ b/embedvar.h @@ -265,6 +265,7 @@ #define PL_scopestack (vTHX->Iscopestack) #define PL_scopestack_ix (vTHX->Iscopestack_ix) #define PL_scopestack_max (vTHX->Iscopestack_max) +#define PL_scopestack_name (vTHX->Iscopestack_name) #define PL_screamfirst (vTHX->Iscreamfirst) #define PL_screamnext (vTHX->Iscreamnext) #define PL_secondgv (vTHX->Isecondgv) @@ -581,6 +582,7 @@ #define PL_Iscopestack PL_scopestack #define PL_Iscopestack_ix PL_scopestack_ix #define PL_Iscopestack_max PL_scopestack_max +#define PL_Iscopestack_name PL_scopestack_name #define PL_Iscreamfirst PL_screamfirst #define PL_Iscreamnext PL_screamnext #define PL_Isecondgv PL_secondgv diff --git a/intrpvar.h b/intrpvar.h index 10cd6b7d34..20df3050f3 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -43,6 +43,9 @@ PERLVAR(Istack_base, SV **) PERLVAR(Istack_max, SV **) PERLVAR(Iscopestack, I32 *) /* scopes we've ENTERed */ +#ifdef DEBUGGING +PERLVAR(Iscopestack_name, const char * *) /* name of the scopes we've ENTERed */ +#endif PERLVAR(Iscopestack_ix, I32) PERLVAR(Iscopestack_max,I32) @@ -3813,6 +3813,9 @@ Perl_init_stacks(pTHX) SET_MARK_OFFSET; Newx(PL_scopestack,REASONABLE(32),I32); +#ifdef DEBUGGING + Newx(PL_scopestack_name,REASONABLE(32),const char*); +#endif PL_scopestack_ix = 0; PL_scopestack_max = REASONABLE(32); @@ -566,6 +566,8 @@ END_EXTERN_C #define PL_scopestack_ix (*Perl_Iscopestack_ix_ptr(aTHX)) #undef PL_scopestack_max #define PL_scopestack_max (*Perl_Iscopestack_max_ptr(aTHX)) +#undef PL_scopestack_name +#define PL_scopestack_name (*Perl_Iscopestack_name_ptr(aTHX)) #undef PL_screamfirst #define PL_screamfirst (*Perl_Iscreamfirst_ptr(aTHX)) #undef PL_screamnext @@ -4523,9 +4523,9 @@ PP(pp_splice) *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg); PUSHMARK(MARK); PUTBACK; - ENTER; + ENTER_with_name("call_SPLICE"); call_method("SPLICE",GIMME_V); - LEAVE; + LEAVE_with_name("call_SPLICE"); SPAGAIN; RETURN; } @@ -4719,9 +4719,9 @@ PP(pp_push) *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg); PUSHMARK(MARK); PUTBACK; - ENTER; + ENTER_with_name("call_PUSH"); call_method("PUSH",G_SCALAR|G_DISCARD); - LEAVE; + LEAVE_with_name("call_PUSH"); SPAGAIN; } else { @@ -4768,9 +4768,9 @@ PP(pp_unshift) *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg); PUSHMARK(MARK); PUTBACK; - ENTER; + ENTER_with_name("call_UNSHIFT"); call_method("UNSHIFT",G_SCALAR|G_DISCARD); - LEAVE; + LEAVE_with_name("call_UNSHIFT"); SPAGAIN; } else { @@ -5330,9 +5330,9 @@ PP(pp_split) } else { PUTBACK; - ENTER; + ENTER_with_name("call_PUSH"); call_method("PUSH",G_SCALAR|G_DISCARD); - LEAVE; + LEAVE_with_name("call_PUSH"); SPAGAIN; if (gimme == G_ARRAY) { I32 i; @@ -996,14 +996,14 @@ PP(pp_grepstart) PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1; pp_pushmark(); /* push dst */ pp_pushmark(); /* push src */ - ENTER; /* enter outer scope */ + ENTER_with_name("grep"); /* enter outer scope */ SAVETMPS; if (PL_op->op_private & OPpGREP_LEX) SAVESPTR(PAD_SVl(PL_op->op_targ)); else SAVE_DEFSV; - ENTER; /* enter inner scope */ + ENTER_with_name("grep_item"); /* enter inner scope */ SAVEVPTR(PL_curpm); src = PL_stack_base[*PL_markstack_ptr]; @@ -1084,13 +1084,13 @@ PP(pp_mapwhile) } } } - LEAVE; /* exit inner scope */ + LEAVE_with_name("grep_item"); /* exit inner scope */ /* All done yet? */ if (PL_markstack_ptr[-1] > *PL_markstack_ptr) { (void)POPMARK; /* pop top */ - LEAVE; /* exit outer scope */ + LEAVE_with_name("grep"); /* exit outer scope */ (void)POPMARK; /* pop src */ items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; (void)POPMARK; /* pop dst */ @@ -1113,7 +1113,7 @@ PP(pp_mapwhile) else { SV *src; - ENTER; /* enter inner scope */ + ENTER_with_name("grep_item"); /* enter inner scope */ SAVEVPTR(PL_curpm); /* set $_ to the new source item */ @@ -1858,7 +1858,7 @@ PP(pp_dbstate) /* don't do recursive DB::DB call */ return NORMAL; - ENTER; + ENTER_with_name("sub"); SAVETMPS; SAVEI32(PL_debug); @@ -1873,7 +1873,7 @@ PP(pp_dbstate) (void)(*CvXSUB(cv))(aTHX_ cv); CvDEPTH(cv)--; FREETMPS; - LEAVE; + LEAVE_with_name("sub"); return NORMAL; } else { @@ -1901,7 +1901,7 @@ PP(pp_enteriter) PAD *iterdata; #endif - ENTER; + ENTER_with_name("loop1"); SAVETMPS; if (PL_op->op_targ) { @@ -1930,7 +1930,7 @@ PP(pp_enteriter) if (PL_op->op_private & OPpITER_DEF) cxtype |= CXp_FOR_DEF; - ENTER; + ENTER_with_name("loop2"); PUSHBLOCK(cx, cxtype, SP); #ifdef USE_ITHREADS @@ -2027,9 +2027,9 @@ PP(pp_enterloop) register PERL_CONTEXT *cx; const I32 gimme = GIMME_V; - ENTER; + ENTER_with_name("loop1"); SAVETMPS; - ENTER; + ENTER_with_name("loop2"); PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP); PUSHLOOP_PLAIN(cx, SP); @@ -2072,8 +2072,8 @@ PP(pp_leaveloop) POPLOOP(cx); /* Stack values are safe: release loop vars ... */ PL_curpm = newpm; /* ... and pop $1 et al */ - LEAVE; - LEAVE; + LEAVE_with_name("loop2"); + LEAVE_with_name("loop1"); return NORMAL; } @@ -2534,7 +2534,7 @@ PP(pp_goto) PUSHMARK(mark); PUTBACK; (void)(*CvXSUB(cv))(aTHX_ cv); - LEAVE; + LEAVE_with_name("sub"); return retop; } else { @@ -2872,7 +2872,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) PERL_ARGS_ASSERT_SV_COMPILE_2OP; - ENTER; + ENTER_with_name("eval"); lex_start(sv, NULL, FALSE); SAVETMPS; /* switch to eval mode */ @@ -2933,7 +2933,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) lex_end(); /* XXX DAPM do this properly one year */ *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad)); - LEAVE; + LEAVE_with_name("eval"); if (IN_PERL_COMPILETIME) CopHINTS_set(&PL_compiling, PL_hints); #ifdef OP_IN_REGISTER @@ -3071,7 +3071,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) POPEVAL(cx); } lex_end(); - LEAVE; /* pp_entereval knows about this LEAVE. */ + LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */ msg = SvPVx_nolen_const(ERRSV); if (optype == OP_REQUIRE) { @@ -3277,9 +3277,9 @@ PP(pp_require) vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) { SV *const importsv = vnormal(sv); *SvPVX_mutable(importsv) = ':'; - ENTER; + ENTER_with_name("load_feature"); Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL); - LEAVE; + LEAVE_with_name("load_feature"); } /* If a version >= 5.11.0 is requested, strictures are on by default! */ if (PL_compcv && @@ -3362,7 +3362,7 @@ PP(pp_require) tryname = SvPVX_const(namesv); tryrsfp = NULL; - ENTER; + ENTER_with_name("call_INC"); SAVETMPS; EXTEND(SP, 2); @@ -3440,7 +3440,7 @@ PP(pp_require) PUTBACK; FREETMPS; - LEAVE; + LEAVE_with_name("call_INC"); if (tryrsfp) { hook_sv = dirsv; @@ -3587,7 +3587,7 @@ PP(pp_require) unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 ); } - ENTER; + ENTER_with_name("eval"); SAVETMPS; lex_start(NULL, tryrsfp, TRUE); @@ -3674,7 +3674,7 @@ PP(pp_entereval) TAINT_IF(SvTAINTED(sv)); TAINT_PROPER("eval"); - ENTER; + ENTER_with_name("eval"); lex_start(sv, NULL, FALSE); SAVETMPS; @@ -3818,7 +3818,7 @@ PP(pp_leaveeval) /* die_where() did LEAVE, or we won't be here */ } else { - LEAVE; + LEAVE_with_name("eval"); if (!(save_flags & OPf_SPECIAL)) { CLEAR_ERRSV(); } @@ -3841,7 +3841,7 @@ Perl_delete_eval_scope(pTHX) POPBLOCK(cx,newpm); POPEVAL(cx); PL_curpm = newpm; - LEAVE; + LEAVE_with_name("eval_scope"); PERL_UNUSED_VAR(newsp); PERL_UNUSED_VAR(gimme); PERL_UNUSED_VAR(optype); @@ -3855,7 +3855,7 @@ Perl_create_eval_scope(pTHX_ U32 flags) PERL_CONTEXT *cx; const I32 gimme = GIMME_V; - ENTER; + ENTER_with_name("eval_scope"); SAVETMPS; PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); @@ -3923,7 +3923,7 @@ PP(pp_leavetry) } PL_curpm = newpm; /* Don't pop $1 et al till now */ - LEAVE; + LEAVE_with_name("eval_scope"); CLEAR_ERRSV(); RETURN; } @@ -3934,7 +3934,7 @@ PP(pp_entergiven) register PERL_CONTEXT *cx; const I32 gimme = GIMME_V; - ENTER; + ENTER_with_name("given"); SAVETMPS; sv_setsv(PAD_SV(PL_op->op_targ), POPs); @@ -3962,7 +3962,7 @@ PP(pp_leavegiven) PL_curpm = newpm; /* pop $1 et al */ - LEAVE; + LEAVE_with_name("given"); return NORMAL; } @@ -3979,7 +3979,7 @@ S_make_matcher(pTHX_ REGEXP *re) PM_SETRE(matcher, ReREFCNT_inc(re)); SAVEFREEOP((OP *) matcher); - ENTER; SAVETMPS; + ENTER_with_name("matcher"); SAVETMPS; SAVEOP(); return matcher; } @@ -4009,7 +4009,7 @@ S_destroy_matcher(pTHX_ PMOP *matcher) PERL_UNUSED_ARG(matcher); FREETMPS; - LEAVE; + LEAVE_with_name("matcher"); } /* Do a smart match */ @@ -4096,7 +4096,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) RETPUSHYES; while ( (he = hv_iternext(hv)) ) { DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n")); - ENTER; + ENTER_with_name("smartmatch_hash_key_test"); SAVETMPS; PUSHMARK(SP); PUSHs(hv_iterkeysv(he)); @@ -4108,7 +4108,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) else andedresults = SvTRUEx(POPs) && andedresults; FREETMPS; - LEAVE; + LEAVE_with_name("smartmatch_hash_key_test"); } if (andedresults) RETPUSHYES; @@ -4127,7 +4127,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) for (i = 0; i <= len; ++i) { SV * const * const svp = av_fetch(av, i, FALSE); DEBUG_M(Perl_deb(aTHX_ " testing array element...\n")); - ENTER; + ENTER_with_name("smartmatch_array_elem_test"); SAVETMPS; PUSHMARK(SP); if (svp) @@ -4140,7 +4140,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) else andedresults = SvTRUEx(POPs) && andedresults; FREETMPS; - LEAVE; + LEAVE_with_name("smartmatch_array_elem_test"); } if (andedresults) RETPUSHYES; @@ -4150,7 +4150,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) else { sm_any_sub: DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n")); - ENTER; + ENTER_with_name("smartmatch_coderef"); SAVETMPS; PUSHMARK(SP); PUSHs(d); @@ -4162,7 +4162,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) else if (SvTEMP(TOPs)) SvREFCNT_inc_void(TOPs); FREETMPS; - LEAVE; + LEAVE_with_name("smartmatch_coderef"); RETURN; } } @@ -4507,7 +4507,7 @@ PP(pp_enterwhen) if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs)) return cLOGOP->op_other->op_next; - ENTER; + ENTER_with_name("eval"); SAVETMPS; PUSHBLOCK(cx, CXt_WHEN, SP); @@ -4532,7 +4532,7 @@ PP(pp_leavewhen) PL_curpm = newpm; /* pop $1 et al */ - LEAVE; + LEAVE_with_name("eval"); return NORMAL; } @@ -4919,7 +4919,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) dSP; int count; - ENTER; + ENTER_with_name("call_filter_sub"); SAVE_DEFSV; SAVETMPS; EXTEND(SP, 2); @@ -4943,7 +4943,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) PUTBACK; FREETMPS; - LEAVE; + LEAVE_with_name("call_filter_sub"); } if(SvOK(upstream)) { @@ -157,7 +157,7 @@ PP(pp_sassign) /* We've been returned a constant rather than a full subroutine, but they expect a subroutine reference to apply. */ if (SvROK(cv)) { - ENTER; + ENTER_with_name("sassign_coderef"); SvREFCNT_inc_void(SvRV(cv)); /* newCONSTSUB takes a reference count on the passed in SV from us. We set the name to NULL, otherwise we get into @@ -167,7 +167,7 @@ PP(pp_sassign) SvRV_set(left, MUTABLE_SV(newCONSTSUB(GvSTASH(right), NULL, SvRV(cv)))); SvREFCNT_dec(cv); - LEAVE; + LEAVE_with_name("sassign_coderef"); } else { /* What can happen for the corner case *{"BONK"} = \&{"BONK"}; is that @@ -719,14 +719,14 @@ PP(pp_print) PUSHMARK(MARK - 1); *MARK = SvTIED_obj(MUTABLE_SV(io), mg); PUTBACK; - ENTER; + ENTER_with_name("call_PRINT"); if( PL_op->op_type == OP_SAY ) { /* local $\ = "\n" */ SAVEGENERICSV(PL_ors_sv); PL_ors_sv = newSVpvs("\n"); } call_method("PRINT", G_SCALAR); - LEAVE; + LEAVE_with_name("call_PRINT"); SPAGAIN; MARK = ORIGMARK + 1; *MARK = *SP; @@ -1554,9 +1554,9 @@ Perl_do_readline(pTHX) PUSHMARK(SP); XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); PUTBACK; - ENTER; + ENTER_with_name("call_READLINE"); call_method("READLINE", gimme); - LEAVE; + LEAVE_with_name("call_READLINE"); SPAGAIN; if (gimme == G_SCALAR) { SV* const result = POPs; @@ -1764,7 +1764,7 @@ PP(pp_enter) gimme = G_SCALAR; } - ENTER; + ENTER_with_name("block"); SAVETMPS; PUSHBLOCK(cx, CXt_BLOCK, SP); @@ -1891,7 +1891,7 @@ PP(pp_leave) } PL_curpm = newpm; /* Don't pop $1 et al till now */ - LEAVE; + LEAVE_with_name("block"); RETURN; } @@ -2378,14 +2378,14 @@ PP(pp_grepwhile) if (SvTRUEx(POPs)) PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr]; ++*PL_markstack_ptr; - LEAVE; /* exit inner scope */ + LEAVE_with_name("grep_item"); /* exit inner scope */ /* All done yet? */ if (PL_stack_base + *PL_markstack_ptr > SP) { I32 items; const I32 gimme = GIMME_V; - LEAVE; /* exit outer scope */ + LEAVE_with_name("grep"); /* exit outer scope */ (void)POPMARK; /* pop src */ items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; (void)POPMARK; /* pop dst */ @@ -2408,7 +2408,7 @@ PP(pp_grepwhile) else { SV *src; - ENTER; /* enter inner scope */ + ENTER_with_name("grep_item"); /* enter inner scope */ SAVEVPTR(PL_curpm); src = PL_stack_base[*PL_markstack_ptr]; @@ -2474,7 +2474,7 @@ PP(pp_leavesub) } PUTBACK; - LEAVE; + LEAVE_with_name("sub"); cxstack_ix--; POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ @@ -2535,7 +2535,7 @@ PP(pp_leavesublv) * the refcounts so the caller gets a live guy. Cannot set * TEMP, so sv_2mortal is out of question. */ if (!CvLVALUE(cx->blk_sub.cv)) { - LEAVE; + LEAVE_with_name("sub"); cxstack_ix--; POPSUB(cx,sv); PL_curpm = newpm; @@ -2550,7 +2550,7 @@ PP(pp_leavesublv) * of a tied hash or array */ if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) && !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) { - LEAVE; + LEAVE_with_name("sub"); cxstack_ix--; POPSUB(cx,sv); PL_curpm = newpm; @@ -2566,7 +2566,7 @@ PP(pp_leavesublv) } } else { /* Should not happen? */ - LEAVE; + LEAVE_with_name("sub"); cxstack_ix--; POPSUB(cx,sv); PL_curpm = newpm; @@ -2583,7 +2583,7 @@ PP(pp_leavesublv) && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { /* Might be flattened array after $#array = */ PUTBACK; - LEAVE; + LEAVE_with_name("sub"); cxstack_ix--; POPSUB(cx,sv); PL_curpm = newpm; @@ -2638,7 +2638,7 @@ PP(pp_leavesublv) } PUTBACK; - LEAVE; + LEAVE_with_name("sub"); cxstack_ix--; POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ @@ -2668,7 +2668,7 @@ PP(pp_entersub) cv = sv_2cv(sv, &stash, &gv, 0); } if (!cv) { - ENTER; + ENTER_with_name("sub"); SAVETMPS; goto try_autoload; } @@ -2722,7 +2722,7 @@ PP(pp_entersub) break; } - ENTER; + ENTER_with_name("sub"); SAVETMPS; retry: @@ -2882,7 +2882,7 @@ try_autoload: *(PL_stack_base + markix) = *PL_stack_sp; PL_stack_sp = PL_stack_base + markix; } - LEAVE; + LEAVE_with_name("sub"); return NORMAL; } } @@ -318,13 +318,13 @@ PP(pp_backtick) NOOP; } else if (gimme == G_SCALAR) { - ENTER; + ENTER_with_name("backtick"); SAVESPTR(PL_rs); PL_rs = &PL_sv_undef; sv_setpvs(TARG, ""); /* note that this preserves previous buffer */ while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL) NOOP; - LEAVE; + LEAVE_with_name("backtick"); XPUSHs(TARG); SvTAINTED_on(TARG); } @@ -364,7 +364,7 @@ PP(pp_glob) * without at the same time croaking, for some reason, or if * perl was built with PERL_EXTERNAL_GLOB */ - ENTER; + ENTER_with_name("glob"); #ifndef VMS if (PL_tainting) { @@ -389,7 +389,7 @@ PP(pp_glob) #endif /* !DOSISH */ result = do_readline(); - LEAVE; + LEAVE_with_name("glob"); return result; } @@ -534,9 +534,9 @@ PP(pp_open) *MARK-- = SvTIED_obj(MUTABLE_SV(io), mg); PUSHMARK(MARK); PUTBACK; - ENTER; + ENTER_with_name("call_OPEN"); call_method("OPEN", G_SCALAR); - LEAVE; + LEAVE_with_name("call_OPEN"); SPAGAIN; RETURN; } @@ -574,9 +574,9 @@ PP(pp_close) PUSHMARK(SP); XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); PUTBACK; - ENTER; + ENTER_with_name("call_CLOSE"); call_method("CLOSE", G_SCALAR); - LEAVE; + LEAVE_with_name("call_CLOSE"); SPAGAIN; RETURN; } @@ -665,9 +665,9 @@ PP(pp_fileno) PUSHMARK(SP); XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); PUTBACK; - ENTER; + ENTER_with_name("call_FILENO"); call_method("FILENO", G_SCALAR); - LEAVE; + LEAVE_with_name("call_FILENO"); SPAGAIN; RETURN; } @@ -740,9 +740,9 @@ PP(pp_binmode) if (discp) XPUSHs(discp); PUTBACK; - ENTER; + ENTER_with_name("call_BINMODE"); call_method("BINMODE", G_SCALAR); - LEAVE; + LEAVE_with_name("call_BINMODE"); SPAGAIN; RETURN; } @@ -820,7 +820,7 @@ PP(pp_tie) } items = SP - MARK++; if (sv_isobject(*MARK)) { /* Calls GET magic. */ - ENTER; + ENTER_with_name("call_TIE"); PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); EXTEND(SP,(I32)items); @@ -840,7 +840,7 @@ PP(pp_tie) DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"", methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no)); } - ENTER; + ENTER_with_name("call_TIE"); PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); EXTEND(SP,(I32)items); @@ -863,7 +863,7 @@ PP(pp_tie) "Self-ties of arrays and hashes are not supported"); sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0); } - LEAVE; + LEAVE_with_name("call_TIE"); SP = PL_stack_base + markoff; PUSHs(sv); RETURN; @@ -890,9 +890,9 @@ PP(pp_untie) XPUSHs(SvTIED_obj(MUTABLE_SV(gv), mg)); mXPUSHi(SvREFCNT(obj) - 1); PUTBACK; - ENTER; + ENTER_with_name("call_UNTIE"); call_sv(MUTABLE_SV(cv), G_VOID); - LEAVE; + LEAVE_with_name("call_UNTIE"); SPAGAIN; } else if (mg && SvREFCNT(obj) > 1) { @@ -91,7 +91,13 @@ Perl_push_scope(pTHX) if (PL_scopestack_ix == PL_scopestack_max) { PL_scopestack_max = GROW(PL_scopestack_max); Renew(PL_scopestack, PL_scopestack_max, I32); +#ifdef DEBUGGING + Renew(PL_scopestack_name, PL_scopestack_max, const char*); +#endif DEBUGGING } +#ifdef DEBUGGING + PL_scopestack_name[PL_scopestack_ix] = "unknown"; +#endif PL_scopestack[PL_scopestack_ix++] = PL_savestack_ix; } @@ -100,6 +100,20 @@ Opening bracket on a callback. See C<LEAVE> and L<perlcall>. =for apidoc Ams||LEAVE Closing bracket on a callback. See C<ENTER> and L<perlcall>. +=over + +=item ENTER_with_name(name) + +Same as C<ENTER>, but when debugging is enabled it also associates the +given literal string with the new scope. + +=item LEAVE_with_name(name) + +Same as C<LEAVE>, but when debugging is enabled it first checks that the +scope has the given name. Name must be a literal string. + +=back + =cut */ @@ -117,9 +131,23 @@ Closing bracket on a callback. See C<ENTER> and L<perlcall>. DEBUG_SCOPE("LEAVE") \ pop_scope(); \ } STMT_END +#define ENTER_with_name(name) \ + STMT_START { \ + push_scope(); \ + PL_scopestack_name[PL_scopestack_ix-1] = name; \ + DEBUG_SCOPE("ENTER \"" name "\"") \ + } STMT_END +#define LEAVE_with_name(name) \ + STMT_START { \ + DEBUG_SCOPE("LEAVE \"" name "\"") \ + assert(strEQ(PL_scopestack_name[PL_scopestack_ix-1], name)); \ + pop_scope(); \ + } STMT_END #else #define ENTER push_scope() #define LEAVE pop_scope() +#define ENTER_with_name(name) ENTER +#define LEAVE_with_name(name) LEAVE #endif #define LEAVE_SCOPE(old) if (PL_savestack_ix > old) leave_scope(old) |