free up CvPADLIST slot for XSUBs for future use

CvRESERVED is a placeholder, it will be replaced with a sentinal value
from future revised BOOTCHECK API.

CvPADLIST_set was helpful during development of this patch, so keep it
around for now.

PoisonPADLIST's magic value is from PERL_POISON 0xEF pattern. Some
PoisonPADLIST locations will get code from future BOOTCHECK API.

Make padlist_dup a NN function to avoid overhead of calling it for XSUBs
during closing.

Perl_cv_undef_flags's else if (CvISXSUB(&cvbody)) is to avoid whitespace
changes.

Filed as perl [#123059].

diff --git a/cv.h b/cv.h
index 2068ca0..f532b45 100644 (file)
--- a/cv.h
+++ b/cv.h
@@ -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

diff --git a/dump.c b/dump.c
index 2d9e019..6da85ee 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -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",

diff --git a/embed.fnc b/embed.fnc
index 53f4b85..930a44d 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -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 \

diff --git a/embed.h b/embed.h
index 50d3824..365104d 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -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 b51e7f5..058a79e 100644 (file)
--- 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 716e444..e470778 100644 (file)
--- 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 c17401b..ae8df05 100644 (file)
--- 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 49dbea3..e235d80 100644 (file)
--- 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 f321e18..0a4c637 100644 (file)
--- 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',

diff --git a/gv.c b/gv.c
index 04013a5..7abc6cc 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -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 804c03c..5f26bcb 100644 (file)
--- 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

diff --git a/op.c b/op.c
index a806fb8..397e3f1 100644 (file)
--- a/op.c
+++ b/op.c
@@ -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);

diff --git a/pad.c b/pad.c
index 309418c..524082e 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -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);

diff --git a/perl.c b/perl.c
index 5acd883..71ba0ff 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -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 f783a9a..cdf0a92 100644 (file)
--- 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
 

diff --git a/pp_ctl.c b/pp_ctl.c
index 212c226..0405185 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -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 */
 
 

diff --git a/proto.h b/proto.h
index d8dc59b..d8994b5 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -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);

diff --git a/sv.c b/sv.c
index 6aa29e1..16f159c 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -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)

diff --git a/sv.h b/sv.h
index 06fd27a..b861817 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -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     \

diff --git a/toke.c b/toke.c
index 25a9ccc..f8af55b 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -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))