diff options
| -rw-r--r-- | cop.h | 85 | ||||
| -rw-r--r-- | embed.fnc | 7 | ||||
| -rw-r--r-- | embed.h | 6 | ||||
| -rw-r--r-- | inline.h | 86 | ||||
| -rw-r--r-- | pp.c | 2 | ||||
| -rw-r--r-- | pp_ctl.c | 16 | ||||
| -rw-r--r-- | pp_hot.c | 10 | ||||
| -rw-r--r-- | pp_sort.c | 4 | ||||
| -rw-r--r-- | proto.h | 12 | ||||
| -rw-r--r-- | t/op/args.t | 4 |
10 files changed, 133 insertions, 99 deletions
@@ -595,20 +595,6 @@ struct block_format { * The context frame holds a reference to the CV so that it can't be * freed while we're executing it */ -#define CX_PUSHSUB_BASE(cx, cv, op, hasargs) \ - ENTRY_PROBE(CvNAMED(cv) \ - ? HEK_KEY(CvNAME_HEK(cv)) \ - : GvENAME(CvGV(cv)), \ - CopFILE((const COP *)CvSTART(cv)), \ - CopLINE((const COP *)CvSTART(cv)), \ - CopSTASHPV((const COP *)CvSTART(cv))); \ - \ - cx->blk_sub.cv = cv; \ - cx->blk_sub.olddepth = CvDEPTH(cv); \ - cx->blk_sub.prevcomppad = PL_comppad; \ - cx->cx_type |= (hasargs) ? CXp_HASARGS : 0; \ - cx->blk_sub.retop = op; \ - SvREFCNT_inc_simple_void_NN(cv); #define CX_PUSHSUB_GET_LVALUE_MASK(func) \ /* If the context is indeterminate, then only the lvalue */ \ @@ -620,20 +606,6 @@ struct block_format { ? 0 : (U8)func(aTHX) \ ) -#define CX_PUSHSUB(cx, cv, op, hasargs) \ - { \ - U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub); \ - CX_PUSHSUB_BASE(cx, cv, op, hasargs) \ - cx->blk_u16 = PL_op->op_private & \ - (phlags|OPpDEREF); \ - } - -/* variant for use by OP_DBSTATE, where op_private holds hint bits */ -#define CX_PUSHSUB_DB(cx, cv, op, hasargs) \ - CX_PUSHSUB_BASE(cx, cv, op, hasargs) \ - cx->blk_u16 = 0; - - #define CX_PUSHFORMAT(cx, cv, gv, retop) \ cx->blk_format.cv = cv; \ cx->blk_format.gv = gv; \ @@ -664,55 +636,6 @@ struct block_format { } STMT_END -/* subsets of CX_POPSUB */ - -#define CX_POPSUB_COMMON(cx) \ - STMT_START { \ - CV *cv; \ - assert(CxTYPE(cx) == CXt_SUB); \ - PL_comppad = cx->blk_sub.prevcomppad; \ - PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL; \ - cv = cx->blk_sub.cv; \ - CvDEPTH(cv) = cx->blk_sub.olddepth; \ - cx->blk_sub.cv = NULL; \ - SvREFCNT_dec(cv); \ - } STMT_END - -/* handle the @_ part of leaving a sub */ - -#define CX_POPSUB_ARGS(cx) \ - STMT_START { \ - AV *av; \ - assert(CxTYPE(cx) == CXt_SUB); \ - assert(AvARRAY(MUTABLE_AV( \ - PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[ \ - CvDEPTH(cx->blk_sub.cv)])) == PL_curpad); \ - CX_POP_SAVEARRAY(cx); \ - av = MUTABLE_AV(PAD_SVl(0)); \ - if (UNLIKELY(AvREAL(av))) \ - /* abandon @_ if it got reified */ \ - clear_defarray(av, 0); \ - else { \ - CLEAR_ARGARRAY(av); \ - } \ - } STMT_END - -#define CX_POPSUB(cx) \ - STMT_START { \ - assert(CxTYPE(cx) == CXt_SUB); \ - RETURN_PROBE(CvNAMED(cx->blk_sub.cv) \ - ? HEK_KEY(CvNAME_HEK(cx->blk_sub.cv)) \ - : GvENAME(CvGV(cx->blk_sub.cv)), \ - CopFILE((COP*)CvSTART((const CV*)cx->blk_sub.cv)), \ - CopLINE((COP*)CvSTART((const CV*)cx->blk_sub.cv)), \ - CopSTASHPV((COP*)CvSTART((const CV*)cx->blk_sub.cv))); \ - \ - if (CxHASARGS(cx)) { \ - CX_POPSUB_ARGS(cx); \ - } \ - CX_POPSUB_COMMON(cx); \ - } STMT_END - #define CX_POPFORMAT(cx) \ STMT_START { \ CV *cv; \ @@ -1299,7 +1222,7 @@ See L<perlcall/LIGHTWEIGHT CALLBACKS>. PUSHSTACKi(PERLSI_MULTICALL); \ cx = cx_pushblock((CXt_SUB|CXp_MULTICALL|flags), gimme, \ PL_stack_sp, PL_savestack_ix); \ - CX_PUSHSUB(cx, cv, NULL, hasargs); \ + cx_pushsub(cx, cv, NULL, cBOOL(hasargs)); \ SAVEOP(); \ saveix_floor = PL_savestack_ix; \ if (!(flags & CXp_SUB_RE_FAKE)) \ @@ -1324,7 +1247,7 @@ See L<perlcall/LIGHTWEIGHT CALLBACKS>. STMT_START { \ cx = CX_CUR(); \ CX_LEAVE_SCOPE(cx); \ - CX_POPSUB_COMMON(cx); \ + cx_popsub_common(cx); \ newsp = PL_stack_base + cx->blk_oldsp; \ gimme = cx->blk_gimme; \ PERL_UNUSED_VAR(newsp); /* for API */ \ @@ -1346,9 +1269,9 @@ See L<perlcall/LIGHTWEIGHT CALLBACKS>. PADLIST * const padlist = CvPADLIST(cv); \ cx = CX_CUR(); \ assert(CxMULTICALL(cx)); \ - CX_POPSUB_COMMON(cx); \ + cx_popsub_common(cx); \ cx->cx_type = (CXt_SUB|CXp_MULTICALL|flags); \ - CX_PUSHSUB(cx, cv, NULL, hasargs); \ + cx_pushsub(cx, cv, NULL, cBOOL(hasargs)); \ if (!(flags & CXp_SUB_RE_FAKE)) \ CvDEPTH(cv)++; \ if (CvDEPTH(cv) >= 2) \ @@ -2875,7 +2875,7 @@ Ei |STRLEN |sv_or_pv_pos_u2b|NN SV *sv|NN const char *pv|STRLEN pos \ #endif EMpPX |SV* |_get_encoding -Xp |void |clear_defarray |NN AV* av|bool abandon +Ap |void |clear_defarray |NN AV* av|bool abandon ApM |void |leave_adjust_stacks|NN SV **from_sp|NN SV **to_sp \ |I32 gimme|int filter @@ -2884,6 +2884,11 @@ ApM |void |leave_adjust_stacks|NN SV **from_sp|NN SV **to_sp \ AiM |PERL_CONTEXT * |cx_pushblock|U8 type|U8 gimme|NN SV** sp|I32 saveix AiM |void |cx_popblock|NN PERL_CONTEXT *cx AiM |void |cx_topblock|NN PERL_CONTEXT *cx +AiM |void |cx_pushsub |NN PERL_CONTEXT *cx|NN CV *cv|NULLOK OP *retop \ + |bool hasargs +AiM |void |cx_popsub_common|NN PERL_CONTEXT *cx +AiM |void |cx_popsub_args |NN PERL_CONTEXT *cx +AiM |void |cx_popsub |NN PERL_CONTEXT *cx #endif : ex: set ts=8 sts=4 sw=4 noet: @@ -87,6 +87,7 @@ #define ck_warner Perl_ck_warner #define ck_warner_d Perl_ck_warner_d #endif +#define clear_defarray(a,b) Perl_clear_defarray(aTHX_ a,b) #ifndef PERL_IMPLICIT_CONTEXT #define croak Perl_croak #endif @@ -778,7 +779,11 @@ #define append_utf8_from_native_byte S_append_utf8_from_native_byte #define av_top_index(a) S_av_top_index(aTHX_ a) #define cx_popblock(a) S_cx_popblock(aTHX_ a) +#define cx_popsub(a) S_cx_popsub(aTHX_ a) +#define cx_popsub_args(a) S_cx_popsub_args(aTHX_ a) +#define cx_popsub_common(a) S_cx_popsub_common(aTHX_ a) #define cx_pushblock(a,b,c,d) S_cx_pushblock(aTHX_ a,b,c,d) +#define cx_pushsub(a,b,c,d) S_cx_pushsub(aTHX_ a,b,c,d) #define cx_topblock(a) S_cx_topblock(aTHX_ a) #define is_safe_syscall(a,b,c,d) S_is_safe_syscall(aTHX_ a,b,c,d) #endif @@ -1159,7 +1164,6 @@ #define ck_svconst(a) Perl_ck_svconst(aTHX_ a) #define ck_tell(a) Perl_ck_tell(aTHX_ a) #define ck_trunc(a) Perl_ck_trunc(aTHX_ a) -#define clear_defarray(a,b) Perl_clear_defarray(aTHX_ a,b) #define closest_cop(a,b,c,d) Perl_closest_cop(aTHX_ a,b,c,d) #define core_prototype(a,b,c,d) Perl_core_prototype(aTHX_ a,b,c,d) #define coresub_op(a,b,c) Perl_coresub_op(aTHX_ a,b,c) @@ -473,6 +473,92 @@ S_cx_topblock(pTHX_ PERL_CONTEXT *cx) } +PERL_STATIC_INLINE void +S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs) +{ + U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub); + + PERL_ARGS_ASSERT_CX_PUSHSUB; + + ENTRY_PROBE(CvNAMED(cv) + ? HEK_KEY(CvNAME_HEK(cv)) + : GvENAME(CvGV(cv)), + CopFILE((const COP *)CvSTART(cv)), + CopLINE((const COP *)CvSTART(cv)), + CopSTASHPV((const COP *)CvSTART(cv))); + cx->blk_sub.cv = cv; + cx->blk_sub.olddepth = CvDEPTH(cv); + cx->blk_sub.prevcomppad = PL_comppad; + cx->cx_type |= (hasargs) ? CXp_HASARGS : 0; + cx->blk_sub.retop = retop; + SvREFCNT_inc_simple_void_NN(cv); + cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF); +} + + +/* subsets of cx_popsub() */ + +PERL_STATIC_INLINE void +S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx) +{ + CV *cv; + + PERL_ARGS_ASSERT_CX_POPSUB_COMMON; + assert(CxTYPE(cx) == CXt_SUB); + + PL_comppad = cx->blk_sub.prevcomppad; + PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL; + cv = cx->blk_sub.cv; + CvDEPTH(cv) = cx->blk_sub.olddepth; + cx->blk_sub.cv = NULL; + SvREFCNT_dec(cv); +} + + +/* handle the @_ part of leaving a sub */ + +PERL_STATIC_INLINE void +S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx) +{ + AV *av; + + PERL_ARGS_ASSERT_CX_POPSUB_ARGS; + assert(CxTYPE(cx) == CXt_SUB); + assert(AvARRAY(MUTABLE_AV( + PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[ + CvDEPTH(cx->blk_sub.cv)])) == PL_curpad); + + CX_POP_SAVEARRAY(cx); + av = MUTABLE_AV(PAD_SVl(0)); + if (UNLIKELY(AvREAL(av))) + /* abandon @_ if it got reified */ + clear_defarray(av, 0); + else { + CLEAR_ARGARRAY(av); + } +} + + +PERL_STATIC_INLINE void +S_cx_popsub(pTHX_ PERL_CONTEXT *cx) +{ + PERL_ARGS_ASSERT_CX_POPSUB; + assert(CxTYPE(cx) == CXt_SUB); + + RETURN_PROBE(CvNAMED(cx->blk_sub.cv) + ? HEK_KEY(CvNAME_HEK(cx->blk_sub.cv)) + : GvENAME(CvGV(cx->blk_sub.cv)), + CopFILE((COP*)CvSTART((const CV*)cx->blk_sub.cv)), + CopLINE((COP*)CvSTART((const CV*)cx->blk_sub.cv)), + CopSTASHPV((COP*)CvSTART((const CV*)cx->blk_sub.cv))); + + if (CxHASARGS(cx)) + cx_popsub_args(cx); + cx_popsub_common(cx); +} + + + /* * ex: set ts=8 sts=4 sw=4 et: */ @@ -6444,7 +6444,7 @@ PP(pp_coreargs) PERL_CONTEXT *cx = CX_CUR(); assert(CxHASARGS(cx)); - CX_POPSUB_ARGS(cx);; + cx_popsub_args(cx);; cx->cx_type &= ~CXp_HASARGS; } } @@ -1366,7 +1366,7 @@ Perl_is_lvalue_sub(pTHX) return 0; } -/* only used by CX_PUSHSUB */ +/* only used by cx_pushsub() */ I32 Perl_was_lvalue_sub(pTHX) { @@ -1531,7 +1531,7 @@ Perl_dounwind(pTHX_ I32 cxix) CX_POPSUBST(cx); break; case CXt_SUB: - CX_POPSUB(cx); + cx_popsub(cx); break; case CXt_EVAL: CX_POPEVAL(cx); @@ -2012,7 +2012,11 @@ PP(pp_dbstate) } else { cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix); - CX_PUSHSUB_DB(cx, cv, PL_op->op_next, 0); + cx_pushsub(cx, cv, PL_op->op_next, 0); + /* OP_DBSTATE's op_private holds hint bits rather than + * the lvalue-ish flags seen in OP_ENTERSUB. So cancel + * any CxLVAL() flags that have now been mis-calculated */ + cx->blk_u16 = 0; SAVEI32(PL_debug); PL_debug = 0; @@ -2347,7 +2351,7 @@ PP(pp_leavesublv) } CX_LEAVE_SCOPE(cx); - CX_POPSUB(cx); /* Stack values are safe: release CV and @_ ... */ + cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */ cx_popblock(cx); retop = cx->blk_sub.retop; CX_POP(cx); @@ -2723,7 +2727,7 @@ PP(pp_goto) CX_LEAVE_SCOPE(cx); if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { - /* this is part of CX_POPSUB_ARGS() */ + /* this is part of cx_popsub_args() */ AV* av = MUTABLE_AV(PAD_SVl(0)); assert(AvARRAY(MUTABLE_AV( PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[ @@ -2823,7 +2827,7 @@ PP(pp_goto) SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ - /* partial unrolled CX_PUSHSUB(): */ + /* partial unrolled cx_pushsub(): */ cx->blk_sub.cv = cv; cx->blk_sub.olddepth = CvDEPTH(cv); @@ -3639,7 +3639,7 @@ PP(pp_leavesub) leave_adjust_stacks(oldsp, oldsp, gimme, 0); CX_LEAVE_SCOPE(cx); - CX_POPSUB(cx); /* Stack values are safe: release CV and @_ ... */ + cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */ cx_popblock(cx); retop = cx->blk_sub.retop; CX_POP(cx); @@ -3763,9 +3763,9 @@ PP(pp_entersub) } /* At this point we want to save PL_savestack_ix, either by doing a - * CX_PUSHSUB, or for XS, doing an ENTER. But we don't yet know the final + * cx_pushsub(), or for XS, doing an ENTER. But we don't yet know the final * CV we will be using (so we don't know whether its XS, so we can't - * CX_PUSHSUB or ENTER yet), and determining cv may itself push stuff on + * cx_pushsub() or ENTER yet), and determining cv may itself push stuff on * the save stack. So remember where we are currently on the save * stack, and later update the CX or scopestack entry accordingly. */ old_savestack_ix = PL_savestack_ix; @@ -3854,7 +3854,7 @@ PP(pp_entersub) gimme = GIMME_V; cx = cx_pushblock(CXt_SUB, gimme, MARK, old_savestack_ix); hasargs = cBOOL(PL_op->op_flags & OPf_STACKED); - CX_PUSHSUB(cx, cv, PL_op->op_next, hasargs); + cx_pushsub(cx, cv, PL_op->op_next, hasargs); padlist = CvPADLIST(cv); if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) @@ -3871,7 +3871,7 @@ PP(pp_entersub) /* it's the responsibility of whoever leaves a sub to ensure * that a clean, empty AV is left in pad[0]. This is normally - * done by CX_POPSUB() */ + * done by cx_popsub() */ assert(!AvREAL(av) && AvFILLp(av) == -1); items = SP - MARK; @@ -1671,7 +1671,7 @@ PP(pp_sort) cx = cx_pushblock(CXt_NULL, gimme, PL_stack_base, old_savestack_ix); if (!(flags & OPf_SPECIAL)) { cx->cx_type = CXt_SUB|CXp_MULTICALL; - CX_PUSHSUB(cx, cv, NULL, hasargs); + cx_pushsub(cx, cv, NULL, hasargs); if (!is_xsub) { PADLIST * const padlist = CvPADLIST(cv); @@ -1703,7 +1703,7 @@ PP(pp_sort) CX_LEAVE_SCOPE(cx); if (!(flags & OPf_SPECIAL)) { assert(CxTYPE(cx) == CXt_SUB); - CX_POPSUB(cx); + cx_popsub(cx); } else assert(CxTYPE(cx) == CXt_NULL); @@ -3721,9 +3721,21 @@ PERL_STATIC_INLINE SSize_t S_av_top_index(pTHX_ AV *av) PERL_STATIC_INLINE void S_cx_popblock(pTHX_ PERL_CONTEXT *cx); #define PERL_ARGS_ASSERT_CX_POPBLOCK \ assert(cx) +PERL_STATIC_INLINE void S_cx_popsub(pTHX_ PERL_CONTEXT *cx); +#define PERL_ARGS_ASSERT_CX_POPSUB \ + assert(cx) +PERL_STATIC_INLINE void S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx); +#define PERL_ARGS_ASSERT_CX_POPSUB_ARGS \ + assert(cx) +PERL_STATIC_INLINE void S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx); +#define PERL_ARGS_ASSERT_CX_POPSUB_COMMON \ + assert(cx) PERL_STATIC_INLINE PERL_CONTEXT * S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix); #define PERL_ARGS_ASSERT_CX_PUSHBLOCK \ assert(sp) +PERL_STATIC_INLINE void S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs); +#define PERL_ARGS_ASSERT_CX_PUSHSUB \ + assert(cx); assert(cv) PERL_STATIC_INLINE void S_cx_topblock(pTHX_ PERL_CONTEXT *cx); #define PERL_ARGS_ASSERT_CX_TOPBLOCK \ assert(cx) diff --git a/t/op/args.t b/t/op/args.t index 2349b84932..23b5505d3e 100644 --- a/t/op/args.t +++ b/t/op/args.t @@ -42,7 +42,7 @@ sub new4 { goto &new2 } is("@$y","a b c y", 'goto: multiple elements'); } -# see if CX_POPSUB gets to see the right pad across a dounwind() with +# see if cx_popsub() gets to see the right pad across a dounwind() with # a reified @_ sub methimpl { @@ -63,7 +63,7 @@ sub try { for (1..5) { try() } is($failcount, 5, - 'CX_POPSUB sees right pad across a dounwind() with reified @_'); + 'cx_popsub sees right pad across a dounwind() with reified @_'); # bug #21542 local $_[0] causes reify problems and coredumps |