diff options
| -rw-r--r-- | cv.h | 28 | ||||
| -rw-r--r-- | dump.c | 10 | ||||
| -rw-r--r-- | embed.fnc | 5 | ||||
| -rw-r--r-- | embed.h | 1 | ||||
| -rw-r--r-- | ext/B/B.pm | 2 | ||||
| -rw-r--r-- | ext/B/B.xs | 12 | ||||
| -rw-r--r-- | ext/Devel-Peek/Peek.pm | 2 | ||||
| -rw-r--r-- | ext/Devel-Peek/Peek.xs | 3 | ||||
| -rw-r--r-- | ext/Devel-Peek/t/Peek.t | 3 | ||||
| -rw-r--r-- | gv.c | 1 | ||||
| -rw-r--r-- | makedef.pl | 1 | ||||
| -rw-r--r-- | op.c | 11 | ||||
| -rw-r--r-- | pad.c | 41 | ||||
| -rw-r--r-- | perl.c | 2 | ||||
| -rw-r--r-- | pod/perldelta.pod | 5 | ||||
| -rw-r--r-- | pp_ctl.c | 2 | ||||
| -rw-r--r-- | proto.h | 8 | ||||
| -rw-r--r-- | sv.c | 9 | ||||
| -rw-r--r-- | sv.h | 5 | ||||
| -rw-r--r-- | toke.c | 2 |
20 files changed, 123 insertions, 30 deletions
@@ -65,7 +65,33 @@ See L<perlguts/Autoloading with XSUBs>. /* For use when you only have a XPVCV*, not a real CV*. Must be assert protected as in S_CvDEPTHp before use. */ #define CvDEPTHunsafe(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_depth -#define CvPADLIST(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist + +/* these CvPADLIST/CvRESERVED asserts can be reverted one day, once stabilized */ +#define CvPADLIST(sv) (*(assert_(!CvISXSUB((CV*)(sv))) \ + &(((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist_u.xcv_padlist))) +/* CvPADLIST_set is not public API, it can be removed one day, once stabilized */ +#ifdef DEBUGGING +# define CvPADLIST_set(sv, padlist) Perl_set_padlist(aTHX_ (CV*)sv, padlist) +#else +# define CvPADLIST_set(sv, padlist) (CvPADLIST(sv) = (padlist)) +#endif +/* CvRESERVED is a placeholder and will be going away soon */ +#define CvRESERVED(sv) *(assert_(CvISXSUB((CV*)(sv))) \ + &(((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist_u.xcv_reserved)) +#ifdef DEBUGGING +# if PTRSIZE == 8 +# define PoisonPADLIST(sv) \ + (((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist_u.xcv_padlist = (PADLIST *)UINT64_C(0xEFEFEFEFEFEFEFEF)) +# elif PTRSIZE == 4 +# define PoisonPADLIST(sv) \ + (((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist_u.xcv_padlist = (PADLIST *)0xEFEFEFEF) +# else +# error unknown pointer size +# endif +#else +# define PoisonPADLIST(sv) +#endif + #define CvOUTSIDE(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_outside #define CvOUTSIDE_SEQ(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_outside_seq #define CvFLAGS(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_flags @@ -2001,10 +2001,14 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv)); Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv)); Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv)); - Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv))); - if (nest < maxnest) { - do_dump_pad(level+1, file, CvPADLIST(sv), 0); + if (!CvISXSUB(sv)) { + Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv))); + if (nest < maxnest) { + do_dump_pad(level+1, file, CvPADLIST(sv), 0); + } } + else + Perl_dump_indent(aTHX_ level, file, " RESERVED = 0x%p\n", CvRESERVED(sv)); { const CV * const outside = CvOUTSIDE(sv); Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n", @@ -2533,6 +2533,9 @@ s |void |deb_stack_n |NN SV** stack_base|I32 stack_min \ : pad API Apda |PADLIST*|pad_new |int flags +#ifdef DEBUGGING +pX |void|set_padlist| NN CV * cv | NULLOK PADLIST * padlist +#endif #if defined(PERL_IN_PAD_C) s |PADOFFSET|pad_alloc_name|NN SV *namesv|U32 flags \ |NULLOK HV *typestash|NULLOK HV *ourstash @@ -2589,7 +2592,7 @@ pd |void |pad_fixup_inner_anons|NN PADLIST *padlist|NN CV *old_cv|NN CV *new_cv pdX |void |pad_push |NN PADLIST *padlist|int depth ApdR |HV* |pad_compname_type|const PADOFFSET po #if defined(USE_ITHREADS) -pdR |PADLIST *|padlist_dup |NULLOK PADLIST *srcpad \ +pdR |PADLIST *|padlist_dup |NN PADLIST *srcpad \ |NN CLONE_PARAMS *param #endif p |PAD ** |padlist_store |NN PADLIST *padlist|I32 key \ @@ -1383,6 +1383,7 @@ # endif # if defined(DEBUGGING) #define get_debug_opts(a,b) Perl_get_debug_opts(aTHX_ a,b) +#define set_padlist(a,b) Perl_set_padlist(aTHX_ a,b) # if defined(PERL_IN_PAD_C) #define cv_dump(a,b) S_cv_dump(aTHX_ a,b) # endif diff --git a/ext/B/B.pm b/ext/B/B.pm index b51e7f574e..058a79e3d0 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -15,7 +15,7 @@ require Exporter; # walkoptree comes from B.xs BEGIN { - $B::VERSION = '1.52'; + $B::VERSION = '1.53'; @B::EXPORT_OK = (); # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK. diff --git a/ext/B/B.xs b/ext/B/B.xs index 716e444ada..e4707787d3 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -1930,6 +1930,10 @@ CvDEPTH(cv) B::PADLIST CvPADLIST(cv) B::CV cv + CODE: + RETVAL = CvISXSUB(cv) ? NULL : CvPADLIST(cv); + OUTPUT: + RETVAL #else @@ -1942,6 +1946,14 @@ CvPADLIST(cv) #endif +SV * +CvRESERVED(cv) + B::CV cv + CODE: + RETVAL = newSViv(CvISXSUB(cv) ? PTR2IV(CvRESERVED(cv)) : 0); + OUTPUT: + RETVAL + void CvXSUB(cv) B::CV cv diff --git a/ext/Devel-Peek/Peek.pm b/ext/Devel-Peek/Peek.pm index c17401b66d..ae8df0565b 100644 --- a/ext/Devel-Peek/Peek.pm +++ b/ext/Devel-Peek/Peek.pm @@ -3,7 +3,7 @@ package Devel::Peek; -$VERSION = '1.18'; +$VERSION = '1.19'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; diff --git a/ext/Devel-Peek/Peek.xs b/ext/Devel-Peek/Peek.xs index 49dbea3216..e235d80417 100644 --- a/ext/Devel-Peek/Peek.xs +++ b/ext/Devel-Peek/Peek.xs @@ -31,7 +31,7 @@ DeadCode(pTHX) for (sv = sva + 1; sv < svend; ++sv) { if (SvTYPE(sv) == SVt_PVCV) { CV *cv = (CV*)sv; - PADLIST* padlist = CvPADLIST(cv); + PADLIST* padlist; AV *argav; SV** svp; SV** pad; @@ -54,6 +54,7 @@ DeadCode(pTHX) PerlIO_printf(Perl_debug_log, " busy\n"); continue; } + padlist = CvPADLIST(cv); svp = (SV**) PadlistARRAY(padlist); while (++i <= PadlistMAX(padlist)) { /* Depth. */ SV **args; diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index f321e188bb..0a4c637302 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -688,7 +688,8 @@ do_test('constant subroutine', FLAGS = 0xc # $] >= 5.013 && $] < 5.015 FLAGS = 0x100c # $] >= 5.015 OUTSIDE_SEQ = 0 - PADLIST = 0x0 + PADLIST = 0x0 # $] < 5.021006 + RESERVED = $ADDR # $] >= 5.021006 OUTSIDE = 0x0 \\(null\\)'); do_test('isUV should show on PVMG', @@ -568,6 +568,7 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, GvCVGEN(gv) = 0; CvISXSUB_on(cv); CvXSUB(cv) = core_xsub; + PoisonPADLIST(cv); } CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE from PL_curcop. */ diff --git a/makedef.pl b/makedef.pl index 804c03c442..5f26bcb03e 100644 --- a/makedef.pl +++ b/makedef.pl @@ -253,6 +253,7 @@ unless ($define{'DEBUGGING'}) { Perl_debstackptrs Perl_pad_sv Perl_pad_setsv + Perl_set_padlist Perl_hv_assert PL_watchaddr PL_watchok @@ -7906,6 +7906,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvXSUB(cv) = const_sv_xsub; CvCONST_on(cv); CvISXSUB_on(cv); + PoisonPADLIST(cv); op_free(block); SvREFCNT_dec(compcv); PL_compcv = NULL; @@ -7940,9 +7941,9 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvFLAGS(compcv) | preserved_flags; CvOUTSIDE(cv) = CvOUTSIDE(compcv); CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv); - CvPADLIST(cv) = CvPADLIST(compcv); + CvPADLIST_set(cv, CvPADLIST(compcv)); CvOUTSIDE(compcv) = temp_cv; - CvPADLIST(compcv) = temp_padl; + CvPADLIST_set(compcv, temp_padl); CvSTART(cv) = CvSTART(compcv); CvSTART(compcv) = cvstart; CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE); @@ -8320,6 +8321,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CvXSUB(cv) = const_sv_xsub; CvCONST_on(cv); CvISXSUB_on(cv); + PoisonPADLIST(cv); } else { if (isGV(gv)) { @@ -8377,9 +8379,9 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, | CvNAMED(cv); CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); - CvPADLIST(cv) = CvPADLIST(PL_compcv); + CvPADLIST_set(cv,CvPADLIST(PL_compcv)); CvOUTSIDE(PL_compcv) = temp_cv; - CvPADLIST(PL_compcv) = temp_av; + CvPADLIST_set(PL_compcv, temp_av); CvSTART(cv) = CvSTART(PL_compcv); CvSTART(PL_compcv) = cvstart; CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE); @@ -8805,6 +8807,7 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */ CvISXSUB_on(cv); CvXSUB(cv) = subaddr; + PoisonPADLIST(cv); if (name) process_special_blocks(0, name, gv, cv); @@ -38,9 +38,11 @@ not callable at will and are always thrown away after the eval"" is done executing). Require'd files are simply evals without any outer lexical scope. -XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad, +XSUBs do not have a CvPADLIST. dXSTARG fetches values from PL_curpad, but that is really the callers pad (a slot of which is allocated by -every entersub). +every entersub). Do not get or set CvPADLIST if a CV is an XSUB (as +determined by C<CvISXSUB()>), CvPADLIST slot is reused for a different +internal purpose in XSUBs. The PADLIST has a C array where pads are stored. @@ -193,6 +195,27 @@ sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U3 || memEQ(SvPVX_const(sv), pv, pvlen)); } +#ifdef DEBUGGING +void +Perl_set_padlist(pTHX_ CV * cv, PADLIST *padlist){ + PERL_ARGS_ASSERT_SET_PADLIST; +# if PTRSIZE == 8 + if((Size_t)padlist == UINT64_C(0xEFEFEFEFEFEFEFEF)){ + assert(0); + } +# elif PTRSIZE == 4 + if((Size_t)padlist == UINT64_C(0xEFEFEFEF)){ + assert(0); + } +# else +# error unknown pointer size +# endif + if(CvISXSUB(cv)){ + assert(0); + } + ((XPVCV*)MUTABLE_PTR(SvANY(cv)))->xcv_padlist_u.xcv_padlist = padlist; +} +#endif /* =for apidoc Am|PADLIST *|pad_new|int flags @@ -398,7 +421,7 @@ Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags) /* This statement and the subsequence if block was pad_undef(). */ pad_peg("pad_undef"); - if (!CvISXSUB(&cvbody) && CvPADLIST(&cvbody)) { + if (!CvISXSUB(&cvbody) && CvPADLIST(&cvbody)) { I32 ix; const PADLIST *padlist = CvPADLIST(&cvbody); @@ -479,10 +502,11 @@ Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags) } if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist)); Safefree(padlist); - CvPADLIST(&cvbody) = NULL; + CvPADLIST_set(&cvbody, NULL); } - else /* future union */ - CvPADLIST(&cvbody) = NULL; + else if (CvISXSUB(&cvbody)) /* future union */ + CvRESERVED(&cvbody) = NULL; + /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */ /* remove CvOUTSIDE unless this is an undef rather than a free */ @@ -2065,7 +2089,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv) SAVESPTR(PL_comppad_name); PL_comppad_name = protopad_name; - CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE); + CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE)); av_fill(PL_comppad, fpad); @@ -2460,9 +2484,6 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param) PERL_ARGS_ASSERT_PADLIST_DUP; - if (!srcpad) - return NULL; - cloneall = param->flags & CLONEf_COPY_STACKS || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1; assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1); @@ -2162,7 +2162,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV)); CvUNIQUE_on(PL_compcv); - CvPADLIST(PL_compcv) = pad_new(0); + CvPADLIST_set(PL_compcv, pad_new(0)); PL_isarev = newHV(); diff --git a/pod/perldelta.pod b/pod/perldelta.pod index f783a9a5a4..cdf0a92714 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -396,7 +396,10 @@ platform specific bugs also go here. =item * -XXX +Starting in 5.21.6, accessing L<perlapi/CvPADLIST> in an XSUB is forbidden. +CvPADLIST has be reused for a different internal purpose for XSUBs. Guard all +CvPADLIST expressions with C<CvISXSUB()> if your code doesn't already block +XSUB CV*s from going through optree CV* expecting code. =back @@ -3383,7 +3383,7 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) /* set up a scratch pad */ - CvPADLIST(evalcv) = pad_new(padnew_SAVE); + CvPADLIST_set(evalcv, pad_new(padnew_SAVE)); PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */ @@ -5430,6 +5430,11 @@ PERL_CALLCONV void Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv) assert(sv) PERL_CALLCONV SV* Perl_pad_sv(pTHX_ PADOFFSET po); +PERL_CALLCONV void Perl_set_padlist(pTHX_ CV * cv, PADLIST * padlist) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_SET_PADLIST \ + assert(cv) + # if defined(PERL_IN_PAD_C) STATIC void S_cv_dump(pTHX_ const CV *cv, const char *title) __attribute__nonnull__(pTHX_1) @@ -8005,9 +8010,10 @@ PERL_CALLCONV OP* Perl_newPADOP(pTHX_ I32 type, I32 flags, SV* sv) PERL_CALLCONV PADLIST * Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param) __attribute__warn_unused_result__ + __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_PADLIST_DUP \ - assert(param) + assert(srcpad); assert(param) PERL_CALLCONV yy_parser* Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param) __attribute__nonnull__(pTHX_2); @@ -13568,7 +13568,14 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) ? NULL : gv_dup(CvGV(sstr), param); - CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param); + if (!CvISXSUB(sstr)) { + if(CvPADLIST(sstr)) + CvPADLIST_set(dstr, padlist_dup(CvPADLIST(sstr), param)); + else + CvPADLIST_set(dstr, NULL); + } else { /* future union here */ + CvRESERVED(dstr) = NULL; + } CvOUTSIDE(dstr) = CvWEAKOUTSIDE(sstr) ? cv_dup( CvOUTSIDE(dstr), param) @@ -592,7 +592,10 @@ typedef U32 cv_flags_t; HEK * xcv_hek; \ } xcv_gv_u; \ char * xcv_file; \ - PADLIST * xcv_padlist; \ + union { \ + PADLIST * xcv_padlist; \ + void * xcv_reserved; \ + } xcv_padlist_u; \ CV * xcv_outside; \ U32 xcv_outside_seq; /* the COP sequence (at the point of our \ * compilation) in the lexically enclosing \ @@ -10538,7 +10538,7 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) CvFLAGS(PL_compcv) |= flags; PL_subline = CopLINE(PL_curcop); - CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB); + CvPADLIST_set(PL_compcv, pad_new(padnew_SAVE|padnew_SAVESUB)); CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv)); CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax; if (outsidecv && CvPADLIST(outsidecv)) |