Stop padlists from being AVs

In order to fix a bug, I need to add new fields to padlists.  But I
cannot easily do that as long as they are AVs.

So I have created a new padlist struct.

This not only allows me to extend the padlist struct with new members
as necessary, but also saves memory, as we now have a three-pointer
struct where before we had a whole SV head (3-4 pointers) + XPVAV (5
pointers).

This will unfortunately break half of CPAN, but the pad API docs
clearly say this:

    NOTE: this function is experimental and may change or be
    removed without notice.

This would have broken B::Debug, but a patch sent upstream has already
been integrated into blead with commit 9d2d23d981.

diff --git a/av.c b/av.c
index f8f123a..e9215f9 100644 (file)
--- a/av.c
+++ b/av.c
@@ -80,23 +80,35 @@ Perl_av_extend(pTHX_ AV *av, I32 key)
                            arg1);
        return;
     }
-    if (key > AvMAX(av)) {
+    av_extend_guts(av,key,&AvMAX(av),&AvALLOC(av),&AvARRAY(av));
+}    
+
+/* The guts of av_extend.  *Not* for general use! */
+void
+Perl_av_extend_guts(pTHX_ AV *av, I32 key, SSize_t *maxp, SV ***allocp,
+                         SV ***arrayp)
+{
+    dVAR;
+
+    PERL_ARGS_ASSERT_AV_EXTEND_GUTS;
+
+    if (key > *maxp) {
        SV** ary;
        I32 tmp;
        I32 newmax;
 
-       if (AvALLOC(av) != AvARRAY(av)) {
-           ary = AvALLOC(av) + AvFILLp(av) + 1;
-           tmp = AvARRAY(av) - AvALLOC(av);
-           Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
-           AvMAX(av) += tmp;
-           AvARRAY(av) = AvALLOC(av);
+       if (av && *allocp != *arrayp) {
+           ary = *allocp + AvFILLp(av) + 1;
+           tmp = *arrayp - *allocp;
+           Move(*arrayp, *allocp, AvFILLp(av)+1, SV*);
+           *maxp += tmp;
+           *arrayp = *allocp;
            if (AvREAL(av)) {
                while (tmp)
                    ary[--tmp] = &PL_sv_undef;
            }
-           if (key > AvMAX(av) - 10) {
-               newmax = key + AvMAX(av);
+           if (key > *maxp - 10) {
+               newmax = key + *maxp;
                goto resize;
            }
        }
@@ -106,7 +118,7 @@ Perl_av_extend(pTHX_ AV *av, I32 key)
              "Out of memory during array extend"; /* Duplicated in pp_hot.c */
 #endif
 
-           if (AvALLOC(av)) {
+           if (*allocp) {
 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
                MEM_SIZE bytes;
                IV itmp;
@@ -126,17 +138,17 @@ Perl_av_extend(pTHX_ AV *av, I32 key)
                   memory that might never be read. So, I feel, better to keep
                   the current lazy system of only writing to it if our caller
                   has a need for more space. NWC  */
-               newmax = Perl_safesysmalloc_size((void*)AvALLOC(av)) /
+               newmax = Perl_safesysmalloc_size((void*)*allocp) /
                    sizeof(const SV *) - 1;
 
                if (key <= newmax) 
                    goto resized;
 #endif 
-               newmax = key + AvMAX(av) / 5;
+               newmax = key + *maxp / 5;
              resize:
                MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
-               Renew(AvALLOC(av),newmax+1, SV*);
+               Renew(*allocp,newmax+1, SV*);
 #else
                bytes = (newmax + 1) * sizeof(const SV *);
 #define MALLOC_OVERHEAD 16
@@ -147,38 +159,38 @@ Perl_av_extend(pTHX_ AV *av, I32 key)
                itmp /= sizeof(const SV *);
                assert(itmp > newmax);
                newmax = itmp - 1;
-               assert(newmax >= AvMAX(av));
+               assert(newmax >= *maxp);
                Newx(ary, newmax+1, SV*);
-               Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
-               Safefree(AvALLOC(av));
-               AvALLOC(av) = ary;
+               Copy(*allocp, ary, *maxp+1, SV*);
+               Safefree(*allocp);
+               *allocp = ary;
 #endif
 #ifdef Perl_safesysmalloc_size
              resized:
 #endif
-               ary = AvALLOC(av) + AvMAX(av) + 1;
-               tmp = newmax - AvMAX(av);
+               ary = *allocp + *maxp + 1;
+               tmp = newmax - *maxp;
                if (av == PL_curstack) {        /* Oops, grew stack (via av_store()?) */
-                   PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
-                   PL_stack_base = AvALLOC(av);
+                   PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base);
+                   PL_stack_base = *allocp;
                    PL_stack_max = PL_stack_base + newmax;
                }
            }
            else {
                newmax = key < 3 ? 3 : key;
                MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
-               Newx(AvALLOC(av), newmax+1, SV*);
-               ary = AvALLOC(av) + 1;
+               Newx(*allocp, newmax+1, SV*);
+               ary = *allocp + 1;
                tmp = newmax;
-               AvALLOC(av)[0] = &PL_sv_undef;  /* For the stacks */
+               *allocp[0] = &PL_sv_undef;      /* For the stacks */
            }
-           if (AvREAL(av)) {
+           if (av && AvREAL(av)) {
                while (tmp)
                    ary[--tmp] = &PL_sv_undef;
            }
            
-           AvARRAY(av) = AvALLOC(av);
-           AvMAX(av) = newmax;
+           *arrayp = *allocp;
+           *maxp = newmax;
        }
     }
 }

diff --git a/dump.c b/dump.c
index bad42b5..0b2eee0 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -2178,7 +2178,7 @@ Perl_debop(pTHX_ const OP *o)
        SV *sv;
         if (cv) {
            PADLIST * const padlist = CvPADLIST(cv);
-            AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
+            PAD * const comppad = *PADLIST_ARRAY(padlist);
             sv = *av_fetch(comppad, o->op_targ, FALSE);
         } else
             sv = NULL;

diff --git a/embed.fnc b/embed.fnc
index 95a4719..dd48aa0 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -193,6 +193,8 @@ Apd |void   |av_clear       |NN AV *av
 Apd    |SV*    |av_delete      |NN AV *av|I32 key|I32 flags
 ApdR   |bool   |av_exists      |NN AV *av|I32 key
 Apd    |void   |av_extend      |NN AV *av|I32 key
+p      |void   |av_extend_guts |NULLOK AV *av|I32 key|NN SSize_t *maxp \
+                               |NN SV ***allocp|NN SV ***arrayp
 ApdR   |SV**   |av_fetch       |NN AV *av|I32 key|I32 lval
 Apd    |void   |av_fill        |NN AV *av|I32 fill
 ApdR   |I32    |av_len         |NN AV *av
@@ -2340,6 +2342,8 @@ ApdR      |HV*    |pad_compname_type|const PADOFFSET po
 pdR    |PADLIST *|padlist_dup  |NULLOK PADLIST *srcpad \
                                |NN CLONE_PARAMS *param
 #endif
+p      |PAD ** |padlist_store  |NN PADLIST *padlist|I32 key \
+                               |NULLOK PAD *val
 
 ApdR   |CV*    |find_runcv     |NULLOK U32 *db_seqp
 pR     |CV*    |find_runcv_where|U8 cond|NULLOK void *arg \

diff --git a/embed.h b/embed.h
index 8c81ee9..0352b30 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1001,6 +1001,7 @@
 #define allocmy(a,b,c)         Perl_allocmy(aTHX_ a,b,c)
 #define amagic_is_enabled(a)   Perl_amagic_is_enabled(aTHX_ a)
 #define apply(a,b,c)           Perl_apply(aTHX_ a,b,c)
+#define av_extend_guts(a,b,c,d,e)      Perl_av_extend_guts(aTHX_ a,b,c,d,e)
 #define bind_match(a,b,c)      Perl_bind_match(aTHX_ a,b,c)
 #define block_end(a,b)         Perl_block_end(aTHX_ a,b)
 #define block_start(a)         Perl_block_start(aTHX_ a)
@@ -1179,6 +1180,7 @@
 #define pad_leavemy()          Perl_pad_leavemy(aTHX)
 #define pad_push(a,b)          Perl_pad_push(aTHX_ a,b)
 #define pad_swipe(a,b)         Perl_pad_swipe(aTHX_ a,b)
+#define padlist_store(a,b,c)   Perl_padlist_store(aTHX_ a,b,c)
 #define parse_unicode_opts(a)  Perl_parse_unicode_opts(aTHX_ a)
 #define parser_free(a)         Perl_parser_free(aTHX_ a)
 #define peep(a)                        Perl_peep(aTHX_ a)

diff --git a/ext/B/B.xs b/ext/B/B.xs
index 2c3d7f8..8d5e511 100644 (file)
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -607,6 +607,9 @@ typedef HE      *B__HE;
 #if PERL_VERSION >= 9
 typedef struct refcounted_he   *B__RHE;
 #endif
+#ifdef PADLIST_ARRAY
+typedef PADLIST        *B__PADLIST;
+#endif
 
 #ifdef MULTIPLICITY
 #  define ASSIGN_COMMON_ALIAS(prefix, var) \
@@ -697,9 +700,19 @@ amagic_generation()
 
 void
 comppadlist()
+    PREINIT:
+       PADLIST *padlist = CvPADLIST(PL_main_cv ? PL_main_cv : PL_compcv);
     PPCODE:
-       PUSHs(make_sv_object(aTHX_ (SV *)(PL_main_cv ? CvPADLIST(PL_main_cv)
-                                                    : CvPADLIST(PL_compcv))));
+#ifdef PADLIST_ARRAY
+       {
+           SV * const rv = sv_newmortal();
+           sv_setiv(newSVrv(rv, padlist ? "B::PADLIST" : "B::NULL"),
+                    PTR2IV(padlist));
+           PUSHs(rv);
+       }
+#else
+       PUSHs(make_sv_object(aTHX_ (SV *)padlist));
+#endif
 
 void
 sv_undef()
@@ -1449,7 +1462,6 @@ MODULE = B        PACKAGE = B::IV
 #define PVCV_stash_ix  sv_SVp | offsetof(struct xpvcv, xcv_stash) 
 #define PVCV_gv_ix     sv_SVp | offsetof(struct xpvcv, xcv_gv)
 #define PVCV_file_ix   sv_char_pp | offsetof(struct xpvcv, xcv_file)
-#define PVCV_padlist_ix        sv_SVp | offsetof(struct xpvcv, xcv_padlist)
 #define PVCV_outside_ix        sv_SVp | offsetof(struct xpvcv, xcv_outside)
 #define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq)
 #define PVCV_flags_ix  sv_U16p | offsetof(struct xpvcv, xcv_flags)
@@ -1504,7 +1516,6 @@ IVX(sv)
        B::CV::STASH = PVCV_stash_ix
        B::CV::GV = PVCV_gv_ix
        B::CV::FILE = PVCV_file_ix
-       B::CV::PADLIST = PVCV_padlist_ix
        B::CV::OUTSIDE = PVCV_outside_ix
        B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
        B::CV::CvFLAGS = PVCV_flags_ix
@@ -1986,6 +1997,20 @@ I32
 CvDEPTH(cv)
         B::CV   cv
 
+#ifdef PADLIST_ARRAY
+
+B::PADLIST
+CvPADLIST(cv)
+       B::CV   cv
+
+#else
+
+B::AV
+CvPADLIST(cv)
+       B::CV   cv
+
+#endif
+
 void
 CvXSUB(cv)
        B::CV   cv
@@ -2068,3 +2093,44 @@ HASH(h)
        RETVAL
 
 #endif
+
+#ifdef PADLIST_ARRAY
+
+MODULE = B     PACKAGE = B::PADLIST    PREFIX = PADLIST_
+
+SSize_t
+PADLIST_MAX(padlist)
+       B::PADLIST      padlist
+
+void
+PADLIST_ARRAY(padlist)
+       B::PADLIST      padlist
+    PPCODE:
+       if (PADLIST_MAX(padlist) >= 0) {
+           PAD **padp = PADLIST_ARRAY(padlist);
+           PADOFFSET i;
+           for (i = 0; i <= PADLIST_MAX(padlist); i++)
+               XPUSHs(make_sv_object(aTHX_ (SV *)padp[i]));
+       }
+
+void
+PADLIST_ARRAYelt(padlist, idx)
+       B::PADLIST      padlist
+       PADOFFSET       idx
+    PPCODE:
+       if (idx >= 0 && PADLIST_MAX(padlist) >= 0
+        && idx <= PADLIST_MAX(padlist))
+           XPUSHs(make_sv_object(aTHX_
+                                 (SV *)PADLIST_ARRAY(padlist)[idx]));
+       else
+           XPUSHs(make_sv_object(aTHX_ NULL));
+
+U32
+PADLIST_REFCNT(padlist)
+       B::PADLIST      padlist
+    CODE:
+       RETVAL = PADLIST_REFCNT(padlist);
+    OUTPUT:
+       RETVAL
+
+#endif

diff --git a/ext/B/B/Xref.pm b/ext/B/B/Xref.pm
index f3a362c..910a5d4 100644 (file)
--- a/ext/B/B/Xref.pm
+++ b/ext/B/B/Xref.pm
@@ -192,7 +192,7 @@ sub load_pad {
     my $padlist = shift;
     my ($namelistav, $vallistav, @namelist, $ix);
     @pad = ();
-    return if class($padlist) eq "SPECIAL";
+    return if class($padlist) =~ '^(?:SPECIAL|NULL)\z';
     ($namelistav,$vallistav) = $padlist->ARRAY;
     @namelist = $namelistav->ARRAY;
     for ($ix = 1; $ix < @namelist; $ix++) {

diff --git a/ext/B/typemap b/ext/B/typemap
index 5e34274..f3e253b 100644 (file)
--- a/ext/B/typemap
+++ b/ext/B/typemap
@@ -36,6 +36,8 @@ PADOFFSET     T_UV
 B::HE          T_HE_OBJ
 B::RHE         T_RHE_OBJ
 
+B::PADLIST     T_PL_OBJ
+
 INPUT
 T_OP_OBJ
        if (SvROK($arg)) {
@@ -77,7 +79,18 @@ T_RHE_OBJ
        else
            croak(\"$var is not a reference\")
 
+T_PL_OBJ
+       if (SvROK($arg)) {
+           IV tmp = SvIV((SV*)SvRV($arg));
+           $var = INT2PTR($type,tmp);
+       }
+       else
+           croak(\"$var is not a reference\")
+
 OUTPUT
+T_SV_OBJ
+       make_sv_object(aTHX_ ($arg), (SV*)($var));
+
 T_MG_OBJ
        sv_setiv(newSVrv($arg, "B::MAGIC"), PTR2IV($var));
 
@@ -86,3 +99,7 @@ T_HE_OBJ
 
 T_RHE_OBJ
        sv_setiv(newSVrv($arg, "B::RHE"), PTR2IV($var));
+
+T_PL_OBJ
+       sv_setiv(newSVrv($arg, $var ? "B::PADLIST" : "B::NULL"),
+                PTR2IV($var));

diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index ffe0c43..0519920 100644 (file)
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -3290,7 +3290,7 @@ CV* cv
   AV *pad_namelist;
   AV *retav = newAV();
  CODE:
-  pad_namelist = (AV*) *av_fetch(CvPADLIST(cv), 0, FALSE);
+  pad_namelist = *PADLIST_ARRAY(CvPADLIST(cv));
 
   for ( i = av_len(pad_namelist); i >= 0; i-- ) {
     SV** name_ptr = av_fetch(pad_namelist, i, 0);

diff --git a/pad.c b/pad.c
index e18560b..057af94 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -228,8 +228,9 @@ PADLIST *
 Perl_pad_new(pTHX_ int flags)
 {
     dVAR;
-    AV *padlist, *padname, *pad;
-    SV **ary;
+    PADLIST *padlist;
+    PAD *padname, *pad;
+    PAD **ary;
 
     ASSERT_CURPAD_LEGAL("pad_new");
 
@@ -260,7 +261,7 @@ Perl_pad_new(pTHX_ int flags)
 
     /* ... create new pad ... */
 
-    padlist    = newAV();
+    Newxz(padlist, 1, PADLIST);
     padname    = newAV();
     pad                = newAV();
 
@@ -282,13 +283,11 @@ Perl_pad_new(pTHX_ int flags)
        array - names, and depth=1.  The default for av_store() is to allocate
        0..3, and even an explicit call to av_extend() with <3 will be rounded
        up, so we inline the allocation of the array here.  */
-    Newx(ary, 2, SV*);
-    AvFILLp(padlist) = 1;
-    AvMAX(padlist) = 1;
-    AvALLOC(padlist) = ary;
-    AvARRAY(padlist) = ary;
-    ary[0] = MUTABLE_SV(padname);
-    ary[1] = MUTABLE_SV(pad);
+    Newx(ary, 2, PAD *);
+    PADLIST_MAX(padlist) = 1;
+    PADLIST_ARRAY(padlist) = ary;
+    ary[0] = padname;
+    ary[1] = pad;
 
     /* ... then update state variables */
 
@@ -381,8 +380,7 @@ Perl_cv_undef(pTHX_ CV *cv)
     /* This statement and the subsequence if block was pad_undef().  */
     pad_peg("pad_undef");
 
-    if (padlist && !SvIS_FREED(padlist) /* may be during global destruction */
-       ) {
+    if (padlist) {
        I32 ix;
 
        /* Free the padlist associated with a CV.
@@ -405,9 +403,9 @@ Perl_cv_undef(pTHX_ CV *cv)
        if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
            CV * const outercv = CvOUTSIDE(cv);
            const U32 seq = CvOUTSIDE_SEQ(cv);
-           AV *  const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
+           PAD * const comppad_name = PADLIST_ARRAY(padlist)[0];
            SV ** const namepad = AvARRAY(comppad_name);
-           AV *  const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
+           PAD * const comppad = PADLIST_ARRAY(padlist)[1];
            SV ** const curpad = AvARRAY(comppad);
            for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
                SV * const namesv = namepad[ix];
@@ -445,11 +443,11 @@ Perl_cv_undef(pTHX_ CV *cv)
            }
        }
 
-       ix = AvFILLp(padlist);
+       ix = PADLIST_MAX(padlist);
        while (ix > 0) {
-           SV* const sv = AvARRAY(padlist)[ix--];
+           PAD * const sv = PADLIST_ARRAY(padlist)[ix--];
            if (sv) {
-               if (sv == (const SV *)PL_comppad) {
+               if (sv == PL_comppad) {
                    PL_comppad = NULL;
                    PL_curpad = NULL;
                }
@@ -457,13 +455,13 @@ Perl_cv_undef(pTHX_ CV *cv)
            }
        }
        {
-           SV *const sv = AvARRAY(padlist)[0];
-           if (sv == (const SV *)PL_comppad_name)
+           PAD * const sv = PADLIST_ARRAY(padlist)[0];
+           if (sv == PL_comppad_name)
                PL_comppad_name = NULL;
            SvREFCNT_dec(sv);
        }
-       AvREAL_off(CvPADLIST(cv));
-       SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
+       if (PADLIST_ARRAY(padlist)) Safefree(PADLIST_ARRAY(padlist));
+       Safefree(padlist);
        CvPADLIST(cv) = NULL;
     }
 
@@ -965,7 +963,7 @@ Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
      *    our $foo = 0 unless defined $foo;
      * to not give a warning. (Yes, this is a hack) */
 
-    nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
+    nameav = PADLIST_ARRAY(CvPADLIST(PL_compcv))[0];
     name_svp = AvARRAY(nameav);
     for (offset = AvFILLp(nameav); offset > 0; offset--) {
         const SV * const namesv = name_svp[offset];
@@ -1082,7 +1080,7 @@ Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
     if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
        return DEFSV;
 
-    return AvARRAY((PAD*) (AvARRAY(CvPADLIST(cv))[CvDEPTH(cv)]))[po];
+    return AvARRAY(PADLIST_ARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
 }
 
 /*
@@ -1145,7 +1143,7 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv,
 
     if (padlist) { /* not an undef CV */
        I32 fake_offset = 0;
-        const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
+        const AV * const nameav = PADLIST_ARRAY(padlist)[0];
        SV * const * const name_svp = AvARRAY(nameav);
 
        for (offset = AvFILLp(nameav); offset > 0; offset--) {
@@ -1276,8 +1274,8 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv,
                        return offset;
                    }
 
-                   *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
-                                   CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
+                   *out_capture = AvARRAY(PADLIST_ARRAY(padlist)[
+                                   CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
                    DEBUG_Xv(PerlIO_printf(Perl_debug_log,
                        "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
                        PTR2UV(cv), PTR2UV(*out_capture)));
@@ -1340,8 +1338,8 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv,
        SV *new_namesv = newSVsv(*out_name_sv);
        AV *  const ocomppad_name = PL_comppad_name;
        PAD * const ocomppad = PL_comppad;
-       PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
-       PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
+       PL_comppad_name = PADLIST_ARRAY(padlist)[0];
+       PL_comppad = PADLIST_ARRAY(padlist)[1];
        PL_curpad = AvARRAY(PL_comppad);
 
        new_offset
@@ -1833,8 +1831,8 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
     if (!padlist) {
        return;
     }
-    pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
-    pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
+    pad_name = *PADLIST_ARRAY(padlist);
+    pad = PADLIST_ARRAY(padlist)[1];
     pname = AvARRAY(pad_name);
     ppad = AvARRAY(pad);
     Perl_dump_indent(aTHX_ level, file,
@@ -1941,10 +1939,8 @@ Perl_cv_clone(pTHX_ CV *proto)
     dVAR;
     I32 ix;
     PADLIST* const protopadlist = CvPADLIST(proto);
-    const AV *const protopad_name =
-       (const AV *)*av_fetch(protopadlist, 0, FALSE);
-    const AV *const protopad =
-       (const AV *)*av_fetch(protopadlist, 1, FALSE);
+    const PAD *const protopad_name = *PADLIST_ARRAY(protopadlist);
+    const PAD *const protopad = PADLIST_ARRAY(protopadlist)[1];
     SV** const pname = AvARRAY(protopad_name);
     SV** const ppad = AvARRAY(protopad);
     const I32 fname = AvFILLp(protopad_name);
@@ -2017,7 +2013,7 @@ Perl_cv_clone(pTHX_ CV *proto)
     PL_curpad = AvARRAY(PL_comppad);
 
     outpad = CvPADLIST(outside)
-       ? AvARRAY(AvARRAY(CvPADLIST(outside))[depth])
+       ? AvARRAY(PADLIST_ARRAY(CvPADLIST(outside))[depth])
        : NULL;
     assert(outpad || SvTYPE(cv) == SVt_PVFM);
 
@@ -2111,8 +2107,8 @@ Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
 {
     dVAR;
     I32 ix;
-    AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
-    AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
+    AV * const comppad_name = PADLIST_ARRAY(padlist)[0];
+    AV * const comppad = PADLIST_ARRAY(padlist)[1];
     SV ** const namepad = AvARRAY(comppad_name);
     SV ** const curpad = AvARRAY(comppad);
 
@@ -2162,8 +2158,8 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
 
     PERL_ARGS_ASSERT_PAD_PUSH;
 
-    if (depth > AvFILLp(padlist)) {
-       SV** const svp = AvARRAY(padlist);
+    if (depth > PADLIST_MAX(padlist) || !PADLIST_ARRAY(padlist)[depth]) {
+       PAD** const svp = PADLIST_ARRAY(padlist);
        AV* const newpad = newAV();
        SV** const oldpad = AvARRAY(svp[depth-1]);
        I32 ix = AvFILLp((const AV *)svp[1]);
@@ -2207,8 +2203,7 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
        av_store(newpad, 0, MUTABLE_SV(av));
        AvREIFY_only(av);
 
-       av_store(padlist, depth, MUTABLE_SV(newpad));
-       AvFILLp(padlist) = depth;
+       padlist_store(padlist, depth, newpad);
     }
 }
 
@@ -2248,48 +2243,52 @@ Duplicates a pad.
 PADLIST *
 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
 {
-    AV *dstpad;
+    PADLIST *dstpad;
+    bool cloneall;
+    PADOFFSET max;
+
     PERL_ARGS_ASSERT_PADLIST_DUP;
 
     if (!srcpad)
        return NULL;
 
-    if (param->flags & CLONEf_COPY_STACKS
-       || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
-       dstpad = av_dup_inc(srcpad, param);
-       assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
+    cloneall = param->flags & CLONEf_COPY_STACKS
+       || SvREFCNT(PADLIST_ARRAY(srcpad)[1]) > 1;
+    assert (SvREFCNT(PADLIST_ARRAY(srcpad)[1]) == 1);
+
+    max = cloneall ? PADLIST_MAX(srcpad) : 1;
+
+    Newx(dstpad, 1, PADLIST);
+    ptr_table_store(PL_ptr_table, srcpad, dstpad);
+    PADLIST_MAX(dstpad) = max;
+    Newx(PADLIST_ARRAY(dstpad), max + 1, PAD *);
+
+    if (cloneall) {
+       PADOFFSET depth;
+       for (depth = 0; depth <= max; ++depth)
+           PADLIST_ARRAY(dstpad)[depth] =
+               av_dup_inc(PADLIST_ARRAY(srcpad)[depth], param);
     } else {
        /* CvDEPTH() on our subroutine will be set to 0, so there's no need
           to build anything other than the first level of pads.  */
-
-       I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
+       I32 ix = AvFILLp(PADLIST_ARRAY(srcpad)[1]);
        AV *pad1;
-       const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
-       const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
+       const I32 names_fill = AvFILLp(PADLIST_ARRAY(srcpad)[0]);
+       const PAD *const srcpad1 = PADLIST_ARRAY(srcpad)[1];
        SV **oldpad = AvARRAY(srcpad1);
        SV **names;
        SV **pad1a;
        AV *args;
-       /* Look for it in the table first, as the padlist may have ended up
-          as an element of @DB::args (or theoretically even @_), so it may
-          may have been cloned already. */
-       dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
-
-       if (dstpad)
-           return (AV *)SvREFCNT_inc_simple_NN(dstpad);
 
-       dstpad = newAV();
-       ptr_table_store(PL_ptr_table, srcpad, dstpad);
-       av_extend(dstpad, 1);
-       AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
-       names = AvARRAY(AvARRAY(dstpad)[0]);
+       PADLIST_ARRAY(dstpad)[0] =
+           av_dup_inc(PADLIST_ARRAY(srcpad)[0], param);
+       names = AvARRAY(PADLIST_ARRAY(dstpad)[0]);
 
        pad1 = newAV();
 
        av_extend(pad1, ix);
-       AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
+       PADLIST_ARRAY(dstpad)[1] = pad1;
        pad1a = AvARRAY(pad1);
-       AvFILLp(dstpad) = 1;
 
        if (ix > -1) {
            AvFILLp(pad1) = ix;
@@ -2357,6 +2356,30 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
 
 #endif /* USE_ITHREADS */
 
+PAD **
+Perl_padlist_store(pTHX_ register PADLIST *padlist, I32 key, PAD *val)
+{
+    dVAR;
+    PAD **ary;
+    SSize_t const oldmax = PADLIST_MAX(padlist);
+
+    PERL_ARGS_ASSERT_PADLIST_STORE;
+
+    assert(key >= 0);
+
+    if (key > PADLIST_MAX(padlist)) {
+       av_extend_guts(NULL,key,&PADLIST_MAX(padlist),
+                      (SV ***)&PADLIST_ARRAY(padlist),
+                      (SV ***)&PADLIST_ARRAY(padlist));
+       Zero(PADLIST_ARRAY(padlist)+oldmax+1, PADLIST_MAX(padlist)-oldmax,
+            PAD *);
+    }
+    ary = PADLIST_ARRAY(padlist);
+    SvREFCNT_dec(ary[key]);
+    ary[key] = val;
+    return &ary[key];
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd

diff --git a/pad.h b/pad.h
index 890ddd1..843cf50 100644 (file)
--- a/pad.h
+++ b/pad.h
@@ -27,6 +27,13 @@ typedef U64TYPE PADOFFSET;
 #endif
 #define NOT_IN_PAD ((PADOFFSET) -1)
 
+
+struct padlist {
+    SSize_t    xpadl_max;      /* max index for which array has space */
+    PAD **     xpadl_alloc;    /* pointer to beginning of array of AVs */
+};
+
+
 /* a value that PL_cop_seqmax is guaranteed never to be,
  * flagging that a lexical is being introduced, or has not yet left scope
  */
@@ -209,6 +216,10 @@ Restore the old pad saved into the local variable opad by PAD_SAVE_LOCAL()
 =cut
 */
 
+#define PADLIST_ARRAY(pl)      (pl)->xpadl_alloc
+#define PADLIST_MAX(pl)                (pl)->xpadl_max
+#define PADLIST_REFCNT(pl)     1       /* reserved for future use */
+
 #ifdef DEBUGGING
 #  define PAD_SV(po)      pad_sv(po)
 #  define PAD_SETSV(po,sv) pad_setsv(po,sv)
@@ -220,12 +231,13 @@ Restore the old pad saved into the local variable opad by PAD_SAVE_LOCAL()
 #define PAD_SVl(po)       (PL_curpad[po])
 
 #define PAD_BASE_SV(padlist, po) \
-       (AvARRAY(padlist)[1])   \
-       ? AvARRAY(MUTABLE_AV((AvARRAY(padlist)[1])))[po] : NULL;
+       (PADLIST_ARRAY(padlist)[1])                                     \
+           ? AvARRAY(MUTABLE_AV((PADLIST_ARRAY(padlist)[1])))[po] \
+           : NULL;
 
 
 #define PAD_SET_CUR_NOSAVE(padlist,nth) \
-       PL_comppad = (PAD*) (AvARRAY(padlist)[nth]);            \
+       PL_comppad = (PAD*) (PADLIST_ARRAY(padlist)[nth]);      \
        PL_curpad = AvARRAY(PL_comppad);                        \
        DEBUG_Xv(PerlIO_printf(Perl_debug_log,                  \
              "Pad 0x%"UVxf"[0x%"UVxf"] set_cur    depth=%d\n", \

diff --git a/perl.h b/perl.h
index 5be85c4..1154c40 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2442,9 +2442,9 @@ typedef struct ptr_tbl_ent PTR_TBL_ENT_t;
 typedef struct ptr_tbl PTR_TBL_t;
 typedef struct clone_params CLONE_PARAMS;
 
-/* a padlist is currently just an AV; but that might change,
- * so hide the type. Ditto a pad.  */
-typedef AV PADLIST;
+/* a pad is currently just an AV; but that might change,
+ * so hide the type.  */
+typedef struct padlist PADLIST;
 typedef AV PAD;
 
 #include "handy.h"

diff --git a/proto.h b/proto.h
index 71de1d3..f06e4e3 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -138,6 +138,13 @@ PERL_CALLCONV void Perl_av_extend(pTHX_ AV *av, I32 key)
 #define PERL_ARGS_ASSERT_AV_EXTEND     \
        assert(av)
 
+PERL_CALLCONV void     Perl_av_extend_guts(pTHX_ AV *av, I32 key, SSize_t *maxp, SV ***allocp, SV ***arrayp)
+                       __attribute__nonnull__(pTHX_3)
+                       __attribute__nonnull__(pTHX_4)
+                       __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_AV_EXTEND_GUTS        \
+       assert(maxp); assert(allocp); assert(arrayp)
+
 PERL_CALLCONV SV**     Perl_av_fetch(pTHX_ AV *av, I32 key, I32 lval)
                        __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_1);
@@ -3022,6 +3029,11 @@ PERL_CALLCONV void       Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
 
 PERL_CALLCONV void     Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust);
 PERL_CALLCONV void     Perl_pad_tidy(pTHX_ padtidy_type type);
+PERL_CALLCONV PAD **   Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PADLIST_STORE \
+       assert(padlist)
+
 PERL_CALLCONV OP*      Perl_parse_arithexpr(pTHX_ U32 flags);
 PERL_CALLCONV OP*      Perl_parse_barestmt(pTHX_ U32 flags);
 PERL_CALLCONV OP*      Perl_parse_block(pTHX_ U32 flags);

diff --git a/sv.c b/sv.c
index 904f4bd..77bb664 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -13904,7 +13904,7 @@ Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
 
        if (!cv || !CvPADLIST(cv))
            return NULL;
-       av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
+       av = *PADLIST_ARRAY(CvPADLIST(cv));
        sv = *av_fetch(av, targ, FALSE);
        sv_setsv(name, sv);
     }