diff options
author | Father Chrysostomos <sprout@cpan.org> | 2012-08-16 16:46:20 -0700 |
---|---|---|
committer | Father Chrysostomos <sprout@cpan.org> | 2012-08-21 16:51:14 -0700 |
commit | 7261499db89d7afd6c64079406dc32f10acfe512 (patch) | |
tree | d28b4da71ab3604a3a0b1258a85fe498d1615cef | |
parent | b70d55581aad461af858eb07a2e80ed5fcc653c1 (diff) | |
download | perl-7261499db89d7afd6c64079406dc32f10acfe512.tar.gz |
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.
-rw-r--r-- | av.c | 66 | ||||
-rw-r--r-- | dump.c | 2 | ||||
-rw-r--r-- | embed.fnc | 4 | ||||
-rw-r--r-- | embed.h | 2 | ||||
-rw-r--r-- | ext/B/B.xs | 74 | ||||
-rw-r--r-- | ext/B/B/Xref.pm | 2 | ||||
-rw-r--r-- | ext/B/typemap | 17 | ||||
-rw-r--r-- | ext/XS-APItest/APItest.xs | 2 | ||||
-rw-r--r-- | pad.c | 151 | ||||
-rw-r--r-- | pad.h | 18 | ||||
-rw-r--r-- | perl.h | 6 | ||||
-rw-r--r-- | proto.h | 12 | ||||
-rw-r--r-- | sv.c | 2 |
13 files changed, 253 insertions, 105 deletions
@@ -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; } } } @@ -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; @@ -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 \ @@ -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 2c3d7f8b94..8d5e511657 100644 --- 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 f3a362c3f6..910a5d475b 100644 --- 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 5e342749d2..f3e253b97d 100644 --- 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 ffe0c43a68..05199208e6 100644 --- 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); @@ -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 @@ -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", \ @@ -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" @@ -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); @@ -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); } |