diff options
author | Father Chrysostomos <sprout@cpan.org> | 2014-11-27 22:30:54 -0800 |
---|---|---|
committer | Father Chrysostomos <sprout@cpan.org> | 2014-11-30 11:48:42 -0800 |
commit | 0f94cb1fe27e58a59d3391214dab34037ab184db (patch) | |
tree | 00f43fa153a153b7e2a1d1728b6a9880264fa132 | |
parent | b19cb98db58c735b4237857f7f69fd857d61934a (diff) | |
download | perl-0f94cb1fe27e58a59d3391214dab34037ab184db.tar.gz |
[perl #123223] Make PADNAME a separate type
distinct from SV. This should fix the CPAN modules that were failing
when the PadnameLVALUE flag was added, because it shared the same
bit as SVs_OBJECT and pad names were going through code paths not
designed to handle pad names.
Unfortunately, it will probably break other CPAN modules, but I think
this change is for the better, as it makes both pad names and SVs sim-
pler and makes pad names take less memory.
-rw-r--r-- | dump.c | 29 | ||||
-rw-r--r-- | embed.fnc | 4 | ||||
-rw-r--r-- | embed.h | 3 | ||||
-rw-r--r-- | ext/B/B.xs | 119 | ||||
-rw-r--r-- | ext/B/B/Showlex.pm | 20 | ||||
-rw-r--r-- | ext/B/Makefile.PL | 4 | ||||
-rw-r--r-- | ext/B/t/showlex.t | 6 | ||||
-rw-r--r-- | op.c | 23 | ||||
-rw-r--r-- | pad.c | 202 | ||||
-rw-r--r-- | pad.h | 151 | ||||
-rw-r--r-- | perl.h | 8 | ||||
-rw-r--r-- | pp.c | 21 | ||||
-rw-r--r-- | proto.h | 26 | ||||
-rw-r--r-- | scope.c | 3 | ||||
-rw-r--r-- | scope.h | 11 | ||||
-rw-r--r-- | sv.c | 40 | ||||
-rw-r--r-- | sv.h | 70 |
17 files changed, 453 insertions, 287 deletions
@@ -1431,15 +1431,10 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv), (int)(PL_dumpindent*level), ""); - if (!((flags & SVpad_NAME) == SVpad_NAME - && (type == SVt_PVMG || type == SVt_PVNV))) { - if ((flags & SVs_PADSTALE)) + if ((flags & SVs_PADSTALE)) sv_catpv(d, "PADSTALE,"); - } - if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) { - if ((flags & SVs_PADTMP)) + if ((flags & SVs_PADTMP)) sv_catpv(d, "PADTMP,"); - } append_flags(d, flags, first_sv_flags_names); if (flags & SVf_ROK) { sv_catpv(d, "ROK,"); @@ -1489,11 +1484,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo case SVt_PVMG: if (SvTAIL(sv)) sv_catpv(d, "TAIL,"); if (SvVALID(sv)) sv_catpv(d, "VALID,"); - if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,"); - if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,"); /* FALLTHROUGH */ - case SVt_PVNV: - if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,"); goto evaled_or_uv; case SVt_PVAV: break; @@ -1562,13 +1553,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo PerlIO_putc(file, '\n'); } - if ((type == SVt_PVNV || type == SVt_PVMG) - && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) { - Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n", - (UV) COP_SEQ_RANGE_LOW(sv)); - Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n", - (UV) COP_SEQ_RANGE_HIGH(sv)); - } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV + if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv)) || type == SVt_NV) { @@ -1638,14 +1623,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo } if (type >= SVt_PVMG) { - if (type == SVt_PVMG && SvPAD_OUR(sv)) { - HV * const ost = SvOURSTASH(sv); - if (ost) - do_hv_dump(level, file, " OURSTASH", ost); - } else { - if (SvMAGIC(sv)) + if (SvMAGIC(sv)) do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim); - } if (SvSTASH(sv)) do_hv_dump(level, file, " STASH", SvSTASH(sv)); @@ -1000,6 +1000,8 @@ AmdbR |HV* |newHV ApaR |HV* |newHVhv |NULLOK HV *hv Apabm |IO* |newIO Apda |OP* |newLISTOP |I32 type|I32 flags|NULLOK OP* first|NULLOK OP* last +AMpda |PADNAME *|newPADNAMEouter|NN PADNAME *outer +AMpda |PADNAME *|newPADNAMEpvn|NN const char *s|STRLEN len AMpda |PADNAMELIST *|newPADNAMELIST|size_t max #ifdef USE_ITHREADS Apda |OP* |newPADOP |I32 type|I32 flags|NN SV* sv @@ -2588,7 +2590,9 @@ AMpdR |PADNAME *|padnamelist_fetch|NN PADNAMELIST *pnl|SSize_t key Xop |void |padnamelist_free|NN PADNAMELIST *pnl AMpd |PADNAME **|padnamelist_store|NN PADNAMELIST *pnl|SSize_t key \ |NULLOK PADNAME *val +Xop |void |padname_free |NN PADNAME *pn #if defined(USE_ITHREADS) +pdR |PADNAME *|padname_dup |NN PADNAME *src|NN CLONE_PARAMS *param pR |PADNAMELIST *|padnamelist_dup|NN PADNAMELIST *srcpad \ |NN CLONE_PARAMS *param pdR |PADLIST *|padlist_dup |NN PADLIST *srcpad \ @@ -385,6 +385,8 @@ #define newNULLLIST() Perl_newNULLLIST(aTHX) #define newOP(a,b) Perl_newOP(aTHX_ a,b) #define newPADNAMELIST(a) Perl_newPADNAMELIST(aTHX_ a) +#define newPADNAMEouter(a) Perl_newPADNAMEouter(aTHX_ a) +#define newPADNAMEpvn(a,b) Perl_newPADNAMEpvn(aTHX_ a,b) #define newPMOP(a,b) Perl_newPMOP(aTHX_ a,b) #define newPROG(a) Perl_newPROG(aTHX_ a) #define newPVOP(a,b,c) Perl_newPVOP(aTHX_ a,b,c) @@ -1758,6 +1760,7 @@ # if defined(USE_ITHREADS) #define mro_meta_dup(a,b) Perl_mro_meta_dup(aTHX_ a,b) #define padlist_dup(a,b) Perl_padlist_dup(aTHX_ a,b) +#define padname_dup(a,b) Perl_padname_dup(aTHX_ a,b) #define padnamelist_dup(a,b) Perl_padnamelist_dup(aTHX_ a,b) # endif # if defined(USE_LOCALE) && (defined(PERL_IN_LOCALE_C) || defined (PERL_EXT_POSIX)) diff --git a/ext/B/B.xs b/ext/B/B.xs index def00a0de8..86bd09cfe5 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -621,6 +621,7 @@ typedef struct refcounted_he *B__RHE; typedef PADLIST *B__PADLIST; #endif typedef PADNAMELIST *B__PADNAMELIST; +typedef PADNAME *B__PADNAME; #ifdef MULTIPLICITY @@ -1340,15 +1341,6 @@ MODULE = B PACKAGE = B::IV #define IV_uvx_ix sv_UVp | STRUCT_OFFSET(struct xpvuv, xuv_uv) #define NV_nvx_ix sv_NVp | STRUCT_OFFSET(struct xpvnv, xnv_u.xnv_nv) -#define NV_cop_seq_range_low_ix \ - sv_U32p | STRUCT_OFFSET(struct xpvnv, xnv_u.xpad_cop_seq.xlow) -#define NV_cop_seq_range_high_ix \ - sv_U32p | STRUCT_OFFSET(struct xpvnv, xnv_u.xpad_cop_seq.xhigh) -#define NV_parent_pad_index_ix \ - sv_U32p | STRUCT_OFFSET(struct xpvnv, xnv_u.xpad_cop_seq.xlow) -#define NV_parent_fakelex_flags_ix \ - sv_U32p | STRUCT_OFFSET(struct xpvnv, xnv_u.xpad_cop_seq.xhigh) - #define PV_cur_ix sv_STRLENp | STRUCT_OFFSET(struct xpv, xpv_cur) #define PV_len_ix sv_STRLENp | STRUCT_OFFSET(struct xpv, xpv_len) @@ -1414,10 +1406,6 @@ IVX(sv) B::IV::IVX = IV_ivx_ix B::IV::UVX = IV_uvx_ix B::NV::NVX = NV_nvx_ix - B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix - B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix - B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix - B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix B::PV::CUR = PV_cur_ix B::PV::LEN = PV_len_ix B::PVMG::SvSTASH = PVMG_stash_ix @@ -2127,20 +2115,113 @@ PadnamelistARRAY(pnl) PADNAME **padp = PadnamelistARRAY(pnl); SSize_t i = 0; for (; i <= PadnamelistMAX(pnl); i++) - XPUSHs(make_sv_object(aTHX_ padp[i])); + { + SV *rv = sv_newmortal(); + sv_setiv(newSVrv(rv,padp[i] ? "B::PADNAME" : "B::SPECIAL"), + PTR2IV(padp[i])); + XPUSHs(rv); + } } -void +B::PADNAME PadnamelistARRAYelt(pnl, idx) B::PADNAMELIST pnl SSize_t idx - PPCODE: + CODE: if (idx < 0 || idx > PadnamelistMAX(pnl)) - XPUSHs(make_sv_object(aTHX_ NULL)); + RETVAL = NULL; else - XPUSHs(make_sv_object(aTHX_ - (SV *)PadnamelistARRAY(pnl)[idx])); + RETVAL = PadnamelistARRAY(pnl)[idx]; + OUTPUT: + RETVAL U32 PadnamelistREFCNT(pnl) B::PADNAMELIST pnl + +MODULE = B PACKAGE = B::PADNAME PREFIX = Padname + +#define PN_type_ix \ + sv_SVp | STRUCT_OFFSET(struct padname,xpadn_type_u.xpadn_typestash) +#define PN_ourstash_ix \ + sv_SVp | STRUCT_OFFSET(struct padname,xpadn_ourstash) +#define PN_len_ix \ + sv_U8p | STRUCT_OFFSET(struct padname,xpadn_len) +#define PN_refcnt_ix \ + sv_U32p | STRUCT_OFFSET(struct padname, xpadn_refcnt) +#define PN_cop_seq_range_low_ix \ + sv_U32p | STRUCT_OFFSET(struct padname, xpadn_low) +#define PN_cop_seq_range_high_ix \ + sv_U32p | STRUCT_OFFSET(struct padname, xpadn_high) +#define PN_parent_pad_index_ix \ + sv_U32p | STRUCT_OFFSET(struct padname, xpadn_low) +#define PN_parent_fakelex_flags_ix \ + sv_U32p | STRUCT_OFFSET(struct padname, xpadn_high) + +void +PadnameTYPE(pn) + B::PADNAME pn + ALIAS: + B::PADNAME::TYPE = PN_type_ix + B::PADNAME::OURSTASH = PN_ourstash_ix + B::PADNAME::LEN = PN_len_ix + B::PADNAME::REFCNT = PN_refcnt_ix + B::PADNAME::COP_SEQ_RANGE_LOW = PN_cop_seq_range_low_ix + B::PADNAME::COP_SEQ_RANGE_HIGH = PN_cop_seq_range_high_ix + B::PADNAME::PARENT_PAD_INDEX = PN_parent_pad_index_ix + B::PADNAME::PARENT_FAKELEX_FLAGS = PN_parent_fakelex_flags_ix + PREINIT: + char *ptr; + SV *ret; + PPCODE: + ptr = (ix & 0xFFFF) + (char *)pn; + switch ((U8)(ix >> 16)) { + case (U8)(sv_SVp >> 16): + ret = make_sv_object(aTHX_ *((SV **)ptr)); + break; + case (U8)(sv_U32p >> 16): + ret = sv_2mortal(newSVuv(*((U32 *)ptr))); + break; + case (U8)(sv_U8p >> 16): + ret = sv_2mortal(newSVuv(*((U8 *)ptr))); + break; + default: + NOT_REACHED; + } + ST(0) = ret; + XSRETURN(1); + +SV * +PadnamePV(pn) + B::PADNAME pn + PREINIT: + dXSTARG; + PPCODE: + PERL_UNUSED_ARG(RETVAL); + sv_setpvn(TARG, PadnamePV(pn), PadnameLEN(pn)); + SvUTF8_on(TARG); + XPUSHTARG; + +BOOT: +{ + /* Uses less memory than an ALIAS. */ + GV *gv = gv_fetchpvs("B::PADNAME::TYPE", 1, SVt_PVGV); + sv_setsv((SV *)gv_fetchpvs("B::PADNAME::SvSTASH",1,SVt_PVGV),(SV *)gv); + sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PROTOCV",1,SVt_PVGV),(SV *)gv); + sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PVX",1,SVt_PVGV), + (SV *)gv_fetchpvs("B::PADNAME::PV" ,1,SVt_PVGV)); +} + +U32 +PadnameFLAGS(pn) + B::PADNAME pn + CODE: + RETVAL = PadnameFLAGS(pn); + /* backward-compatibility hack, which should be removed if the + flags field becomes large enough to hold SVf_FAKE (and + PADNAMEt_OUTER should be renumbered to match SVf_FAKE) */ + assert(SVf_FAKE >= 1<<(sizeof(PadnameFLAGS(pn)) * 8)); + if (PadnameOUTER(pn)) + RETVAL |= SVf_FAKE; + OUTPUT: + RETVAL diff --git a/ext/B/B/Showlex.pm b/ext/B/B/Showlex.pm index 74b2befec0..4ccb26d29e 100644 --- a/ext/B/B/Showlex.pm +++ b/ext/B/B/Showlex.pm @@ -36,7 +36,8 @@ sub shownamearray { for ($i = 0; $i < $count; $i++) { my $sv = $els[$i]; if (class($sv) ne "SPECIAL") { - printf $walkHandle "$i: %s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX; + printf $walkHandle "$i: (0x%lx) %s\n", + $$sv, $sv->PVX // "undef" || "const"; } else { printf $walkHandle "$i: %s\n", $sv->terse; #printf $walkHandle "$i: %s\n", B::Concise::concise_sv($sv); @@ -64,16 +65,27 @@ sub showlex { my ($newlex, $nosp1); # rendering state vars +sub padname_terse { + my $name = shift; + return $name->terse if class($name) eq 'SPECIAL'; + my $str = $name->PVX; + return sprintf "(0x%lx) %s", + $$name, + length $str ? qq'"$str"' : defined $str ? "const" : 'undef'; +} + sub newlex { # drop-in for showlex my ($objname, $names, $vals) = @_; my @names = $names->ARRAY; my @vals = $vals->ARRAY; my $count = @names; print $walkHandle "$objname Pad has $count entries\n"; - printf $walkHandle "0: %s\n", $names[0]->terse unless $nosp1; + printf $walkHandle "0: %s\n", padname_terse($names[0]) unless $nosp1; for (my $i = 1; $i < $count; $i++) { - printf $walkHandle "$i: %s = %s\n", $names[$i]->terse, $vals[$i]->terse - unless $nosp1 and $names[$i]->terse =~ /SPECIAL/; + printf $walkHandle "$i: %s = %s\n", padname_terse($names[$i]), + $vals[$i]->terse, + unless $nosp1 + and class($names[$i]) eq 'SPECIAL' || !$names[$i]->LEN; } } diff --git a/ext/B/Makefile.PL b/ext/B/Makefile.PL index cc16ad9812..8708c0d1c7 100644 --- a/ext/B/Makefile.PL +++ b/ext/B/Makefile.PL @@ -15,7 +15,8 @@ if ($core) { } my @names = ({ name => 'HEf_SVKEY', macro => 1, type => "IV" }, - qw(SVTYPEMASK SVt_PVGV SVt_PVHV PAD_FAKELEX_ANON PAD_FAKELEX_MULTI)); + qw(SVTYPEMASK SVt_PVGV SVt_PVHV PAD_FAKELEX_ANON + PAD_FAKELEX_MULTI SVpad_STATE SVpad_TYPED SVpad_OUR)); my @depend; @@ -29,6 +30,7 @@ foreach my $tuple (['cop.h'], ['op.h'], ['opcode.h', 'OPp'], ['op_reg_common.h','(?:(?:RXf_)?PMf_)'], + ['pad.h','PADNAMEt_'], ['regexp.h','RXf_'], ['sv.h', 'SV(?:[fps]|pad)_'], ) { diff --git a/ext/B/t/showlex.t b/ext/B/t/showlex.t index 2871622a5d..dd5cdb7f38 100644 --- a/ext/B/t/showlex.t +++ b/ext/B/t/showlex.t @@ -31,7 +31,7 @@ if ($is_thread) { ok "# use5005threads: test skipped\n"; } else { $a = `$^X $path "-MO=Showlex" -e "my \@one" 2>&1`; - like ($a, qr/sv_undef.*PVNV.*\@one.*Nullsv.*AV/s, + like ($a, qr/undef.*: \([^)]*\) \@one.*Nullsv.*AV/s, "canonical usage works"); } @@ -43,8 +43,8 @@ my ($out, $newlex); # output, option-flag sub padrep { my ($varname,$newlex) = @_; return ($newlex) - ? 'PVNV \(0x[0-9a-fA-F]+\) "\\'.$varname.'" = ' - : "PVNV \\\(0x[0-9a-fA-F]+\\\) \\$varname\n"; + ? '\(0x[0-9a-fA-F]+\) "\\'.$varname.'" = ' + : "\\\(0x[0-9a-fA-F]+\\\) \\$varname\n"; } for $newlex ('', '-newlex') { @@ -7780,7 +7780,7 @@ S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex) SAVEFREESV(sv); } else if (allow_lex && type == OP_PADSV) { - if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE) + if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER) { sv = &PL_sv_undef; /* an arbitrary non-null value */ padsv = TRUE; @@ -7922,9 +7922,6 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else if (PadnameIsSTATE(name) || CvDEPTH(outcv)) cv = *spot; else { - MAGIC *mg; - SvUPGRADE((SV *)name, SVt_PVMG); - mg = mg_find((SV *)name, PERL_MAGIC_proto); assert (SvTYPE(*spot) == SVt_PVCV); if (CvNAMED(*spot)) hek = CvNAME_HEK(*spot); @@ -7941,15 +7938,8 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) ); CvLEXICAL_on(*spot); } - if (mg) { - assert(mg->mg_obj); - cv = (CV *)mg->mg_obj; - } - else { - sv_magic((SV *)name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0); - mg = mg_find((SV *)name, PERL_MAGIC_proto); - } - spot = (CV **)(svspot = &mg->mg_obj); + cv = PadnamePROTOCV(name); + svspot = (SV **)(spot = &PadnamePROTOCV(name)); } if (block) { @@ -11003,11 +10993,8 @@ Perl_find_lexical_cv(pTHX_ PADOFFSET off) [off = PARENT_PAD_INDEX(name)]; } assert(!PadnameIsOUR(name)); - if (!PadnameIsSTATE(name) && SvMAGICAL(name)) { - MAGIC * mg = mg_find((SV *)name, PERL_MAGIC_proto); - assert(mg); - assert(mg->mg_obj); - return (CV *)mg->mg_obj; + if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) { + return PadnamePROTOCV(name); } return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off]; } @@ -147,14 +147,12 @@ Points directly to the body of the L</PL_comppad> array. #include "keywords.h" #define COP_SEQ_RANGE_LOW_set(sv,val) \ - STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END + STMT_START { (sv)->xpadn_low = (val); } STMT_END #define COP_SEQ_RANGE_HIGH_set(sv,val) \ - STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END + STMT_START { (sv)->xpadn_high = (val); } STMT_END -#define PARENT_PAD_INDEX_set(sv,val) \ - STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END -#define PARENT_FAKELEX_FLAGS_set(sv,val) \ - STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END +#define PARENT_PAD_INDEX_set COP_SEQ_RANGE_LOW_set +#define PARENT_FAKELEX_FLAGS_set COP_SEQ_RANGE_HIGH_set #ifdef DEBUGGING void @@ -242,7 +240,7 @@ Perl_pad_new(pTHX_ int flags) else { av_store(pad, 0, NULL); padname = newPADNAMELIST(0); - padnamelist_store(padname, 0, &PL_sv_undef); + padnamelist_store(padname, 0, &PL_padname_undef); } /* Most subroutines never recurse, hence only need 2 entries in the padlist @@ -550,9 +548,9 @@ S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash, ASSERT_CURPAD_ACTIVE("pad_alloc_name"); if (typestash) { - assert(SvTYPE(name) == SVt_PVMG); SvPAD_TYPED_on(name); - SvSTASH_set(name, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)))); + PadnameTYPE(name) = + MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))); } if (ourstash) { SvPAD_OUR_on(name); @@ -563,7 +561,7 @@ S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash, SvPAD_STATE_on(name); } - padnamelist_store(PL_comppad_name, offset, (SV *)name); + padnamelist_store(PL_comppad_name, offset, name); PadnamelistMAXNAMED(PL_comppad_name) = offset; return offset; } @@ -602,18 +600,14 @@ Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf, (UV)flags); - name = (PADNAME *) - newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV); - - sv_setpvn((SV *)name, namepv, namelen); - SvUTF8_on(name); + name = newPADNAMEpvn(namepv, namelen); if ((flags & padadd_NO_DUP_CHECK) == 0) { ENTER; - SAVEFREESV(name); /* in case of fatal warnings */ + SAVEFREEPADNAME(name); /* in case of fatal warnings */ /* check for duplicate declaration */ pad_check_dup(name, flags & padadd_OUR, ourstash); - SvREFCNT_inc_simple_void_NN(name); + PadnameREFCNT(name)++; LEAVE; } @@ -763,7 +757,7 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) break; } if (konst) { - padnamelist_store(PL_comppad_name, retval, &PL_sv_no); + padnamelist_store(PL_comppad_name, retval, &PL_padname_const); tmptype &= ~SVf_READONLY; tmptype |= SVs_PADTMP; } @@ -805,16 +799,15 @@ PADOFFSET Perl_pad_add_anon(pTHX_ CV* func, I32 optype) { PADOFFSET ix; - SV* const name = newSV_type(SVt_PVNV); + PADNAME * const name = newPADNAMEpvn("&", 1); PERL_ARGS_ASSERT_PAD_ADD_ANON; pad_peg("add_anon"); - sv_setpvs(name, "&"); /* These two aren't used; just make sure they're not equal to - * PERL_PADSEQ_INTRO */ - COP_SEQ_RANGE_LOW_set(name, 0); - COP_SEQ_RANGE_HIGH_set(name, 0); + * PERL_PADSEQ_INTRO. They should be 0 by default. */ + assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO); + assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO); ix = pad_alloc(optype, SVs_PADMY); padnamelist_store(PL_comppad_name, ix, name); /* XXX DAPM use PL_curpad[] ? */ @@ -1317,7 +1310,7 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, type as the source, independent of the flags set, and on it being "good" and only copying flag bits and pointers that it understands. */ - PADNAME *new_name = (PADNAME *)newSVsv((SV *)*out_name); + PADNAME *new_name = newPADNAMEouter(*out_name); PADNAMELIST * const ocomppad_name = PL_comppad_name; PAD * const ocomppad = PL_comppad; PL_comppad_name = PadlistNAMES(padlist); @@ -1331,7 +1324,6 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, PadnameOURSTASH(*out_name) ); - SvFAKE_on(new_name); DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad addname: %ld \"%.*s\" FAKE\n", (long)new_offset, @@ -1608,7 +1600,7 @@ Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust) if (PadnamelistARRAY(PL_comppad_name)[po]) { assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po])); } - PadnamelistARRAY(PL_comppad_name)[po] = (PADNAME *)&PL_sv_undef; + PadnamelistARRAY(PL_comppad_name)[po] = &PL_padname_undef; } /* Use PL_constpadix here, not PL_padix. The latter may have been reset by pad_reset. We don’t want pad_alloc to have to scan the @@ -1749,10 +1741,10 @@ Perl_pad_tidy(pTHX_ padtidy_type type) PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name); PADOFFSET ix; for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { - if (!namep[ix]) namep[ix] = &PL_sv_undef; + if (!namep[ix]) namep[ix] = &PL_padname_undef; if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])) continue; - if (SvPADMY(PL_curpad[ix]) && !SvFAKE(namep[ix])) { + if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) { /* This is a work around for how the current implementation of ?{ } blocks in regexps interacts with lexicals. @@ -2315,23 +2307,25 @@ Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv) I32 ix; PADNAMELIST * const comppad_name = PadlistNAMES(padlist); AV * const comppad = PadlistARRAY(padlist)[1]; - SV ** const namepad = PadnamelistARRAY(comppad_name); + PADNAME ** const namepad = PadnamelistARRAY(comppad_name); SV ** const curpad = AvARRAY(comppad); PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS; PERL_UNUSED_ARG(old_cv); for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) { - const SV * const namesv = namepad[ix]; - if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv) - && *SvPVX_const(namesv) == '&') + const PADNAME * const name = namepad[ix]; + if (name && name != &PL_padname_undef && !PadnameIsSTATE(name) + && *PadnamePV(name) == '&') { if (SvTYPE(curpad[ix]) == SVt_PVCV) { - MAGIC * const mg = - SvMAGICAL(curpad[ix]) - ? mg_find(curpad[ix], PERL_MAGIC_proto) - : NULL; - CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]); + /* XXX 0afba48f added code here to check for a proto CV + attached to the pad entry by magic. But shortly there- + after 81df9f6f95 moved the magic to the pad name. The + code here was never updated, so it wasn’t doing anything + and got deleted when PADNAME became a distinct type. Is + there any bug as a result? */ + CV * const innercv = MUTABLE_CV(curpad[ix]); if (CvOUTSIDE(innercv) == old_cv) { if (!CvWEAKOUTSIDE(innercv)) { SvREFCNT_dec(old_cv); @@ -2613,7 +2607,8 @@ Perl_padnamelist_store(pTHX_ PADNAMELIST *pnl, SSize_t key, PADNAME *val) PadnamelistMAX(pnl) = key; } ary = PadnamelistARRAY(pnl); - SvREFCNT_dec(ary[key]); + if (ary[key]) + PadnameREFCNT_dec(ary[key]); ary[key] = val; return &ary[key]; } @@ -2641,7 +2636,12 @@ Perl_padnamelist_free(pTHX_ PADNAMELIST *pnl) PERL_ARGS_ASSERT_PADNAMELIST_FREE; if (!--PadnamelistREFCNT(pnl)) { while(PadnamelistMAX(pnl) >= 0) - SvREFCNT_dec(PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--]); + { + PADNAME * const pn = + PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--]; + if (pn) + PadnameREFCNT_dec(pn); + } Safefree(PadnamelistARRAY(pnl)); Safefree(pnl); } @@ -2677,14 +2677,136 @@ Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param) ptr_table_store(PL_ptr_table, srcpad, dstpad); for (; max >= 0; max--) + if (PadnamelistARRAY(srcpad)[max]) { PadnamelistARRAY(dstpad)[max] = - sv_dup_inc(PadnamelistARRAY(srcpad)[max], param); + padname_dup(PadnamelistARRAY(srcpad)[max], param); + PadnameREFCNT(PadnamelistARRAY(dstpad)[max])++; + } return dstpad; } #endif /* USE_ITHREADS */ +/* +=for apidoc newPADNAMEpvn + +Constructs and returns a new pad name. I<s> must be a UTF8 string. Do not +use this for pad names that point to outer lexicals. See +L</newPADNAMEouter>. + +=cut +*/ + +PADNAME * +Perl_newPADNAMEpvn(pTHX_ const char *s, STRLEN len) +{ + struct padname_with_str *alloc; + char *alloc2; /* for Newxz */ + PADNAME *pn; + PERL_ARGS_ASSERT_NEWPADNAMEPVN; + Newxz(alloc2, + STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1, + char); + alloc = (struct padname_with_str *)alloc2; + pn = (PADNAME *)alloc; + PadnameREFCNT(pn) = 1; + PadnamePV(pn) = alloc->xpadn_str; + Copy(s, PadnamePV(pn), len, char); + *(PadnamePV(pn) + len) = '\0'; + PadnameLEN(pn) = len; + return pn; +} + +/* +=for apidoc newPADNAMEouter + +Constructs and returns a new pad name. Only use this function for names +that refer to outer lexicals. (See also L</newPADNAMEpvn>.) I<outer> is +the outer pad name that this one mirrors. The returned pad name has the +PADNAMEt_OUTER flag already set. + +=cut +*/ + +PADNAME * +Perl_newPADNAMEouter(pTHX_ PADNAME *outer) +{ + PADNAME *pn; + PERL_ARGS_ASSERT_NEWPADNAMEOUTER; + Newxz(pn, 1, PADNAME); + PadnameREFCNT(pn) = 1; + PadnamePV(pn) = PadnamePV(outer); + /* Not PadnameREFCNT(outer), because ‘outer’ may itself close over + another entry. The original pad name owns the buffer. */ + PadnameREFCNT(PADNAME_FROM_PV(PadnamePV(outer)))++; + PadnameFLAGS(pn) = PADNAMEt_OUTER; + PadnameLEN(pn) = PadnameLEN(outer); + return pn; +} + +void +Perl_padname_free(pTHX_ PADNAME *pn) +{ + PERL_ARGS_ASSERT_PADNAME_FREE; + if (!--PadnameREFCNT(pn)) { + if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) { + PadnameREFCNT(pn) = SvREFCNT_IMMORTAL; + return; + } + SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too. */ + SvREFCNT_dec(PadnameOURSTASH(pn)); + if (PadnameOUTER(pn)) + PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn))); + Safefree(pn); + } +} + +#if defined(USE_ITHREADS) + +/* +=for apidoc padname_dup + +Duplicates a pad name. + +=cut +*/ + +PADNAME * +Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param) +{ + PADNAME *dst; + + PERL_ARGS_ASSERT_PADNAME_DUP; + + /* look for it in the table first */ + dst = (PADNAME *)ptr_table_fetch(PL_ptr_table, src); + if (dst) + return dst; + + if (!PadnamePV(src)) { + dst = &PL_padname_undef; + ptr_table_store(PL_ptr_table, src, dst); + return dst; + } + + dst = PadnameOUTER(src) + ? newPADNAMEouter(padname_dup(PADNAME_FROM_PV(PadnamePV(src)), param)) + : newPADNAMEpvn(PadnamePV(src), PadnameLEN(src)); + ptr_table_store(PL_ptr_table, src, dst); + PadnameLEN(dst) = PadnameLEN(src); + PadnameFLAGS(dst) = PadnameFLAGS(src); + PadnameREFCNT(dst) = 0; /* The caller will increment it. */ + PadnameTYPE (dst) = (HV *)sv_dup_inc((SV *)PadnameTYPE(src), param); + PadnameOURSTASH(dst) = (HV *)sv_dup_inc((SV *)PadnameOURSTASH(src), + param); + dst->xpadn_low = src->xpadn_low; + dst->xpadn_high = src->xpadn_high; + dst->xpadn_gen = src->xpadn_gen; + return dst; +} + +#endif /* USE_ITHREADS */ /* * Local variables: @@ -45,6 +45,29 @@ struct padnamelist { U32 xpadnl_refcnt; }; +struct padname { + char * xpadn_pv; + HV * xpadn_ourstash; + union { + HV * xpadn_typestash; + CV * xpadn_protocv; + } xpadn_type_u; + U32 xpadn_low; + U32 xpadn_high; + U32 xpadn_refcnt; + int xpadn_gen; + U8 xpadn_len; + U8 xpadn_flags; +}; + +struct padname_with_str { + struct padname xpadn_padname; + char xpadn_str[1]; +}; + +#define PADNAME_FROM_PV(s) \ + ((PADNAME *)((s) - STRUCT_OFFSET(struct padname_with_str, xpadn_str))) + /* a value that PL_cop_seqmax is guaranteed never to be, * flagging that a lexical is being introduced, or has not yet left scope @@ -59,63 +82,10 @@ struct padnamelist { /* Low range end is exclusive (valid from the cop seq after this one) */ /* High range end is inclusive (valid up to this cop seq) */ -#if defined (DEBUGGING) && defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) -# define COP_SEQ_RANGE_LOW(sv) \ - (({ const SV *const _sv_cop_seq_range_low = (const SV *) (sv); \ - assert(SvTYPE(_sv_cop_seq_range_low) == SVt_NV \ - || SvTYPE(_sv_cop_seq_range_low) >= SVt_PVNV); \ - assert(SvTYPE(_sv_cop_seq_range_low) != SVt_PVAV); \ - assert(SvTYPE(_sv_cop_seq_range_low) != SVt_PVHV); \ - assert(SvTYPE(_sv_cop_seq_range_low) != SVt_PVCV); \ - assert(SvTYPE(_sv_cop_seq_range_low) != SVt_PVFM); \ - assert(!isGV_with_GP(_sv_cop_seq_range_low)); \ - ((XPVNV*) MUTABLE_PTR(SvANY(_sv_cop_seq_range_low)))->xnv_u.xpad_cop_seq.xlow; \ - })) -# define COP_SEQ_RANGE_HIGH(sv) \ - (({ const SV *const _sv_cop_seq_range_high = (const SV *) (sv); \ - assert(SvTYPE(_sv_cop_seq_range_high) == SVt_NV \ - || SvTYPE(_sv_cop_seq_range_high) >= SVt_PVNV); \ - assert(SvTYPE(_sv_cop_seq_range_high) != SVt_PVAV); \ - assert(SvTYPE(_sv_cop_seq_range_high) != SVt_PVHV); \ - assert(SvTYPE(_sv_cop_seq_range_high) != SVt_PVCV); \ - assert(SvTYPE(_sv_cop_seq_range_high) != SVt_PVFM); \ - assert(!isGV_with_GP(_sv_cop_seq_range_high)); \ - ((XPVNV*) MUTABLE_PTR(SvANY(_sv_cop_seq_range_high)))->xnv_u.xpad_cop_seq.xhigh; \ - })) -# define PARENT_PAD_INDEX(sv) \ - (({ const SV *const _sv_parent_pad_index = (const SV *) (sv); \ - assert(SvTYPE(_sv_parent_pad_index) == SVt_NV \ - || SvTYPE(_sv_parent_pad_index) >= SVt_PVNV); \ - assert(SvTYPE(_sv_parent_pad_index) != SVt_PVAV); \ - assert(SvTYPE(_sv_parent_pad_index) != SVt_PVHV); \ - assert(SvTYPE(_sv_parent_pad_index) != SVt_PVCV); \ - assert(SvTYPE(_sv_parent_pad_index) != SVt_PVFM); \ - assert(!isGV_with_GP(_sv_parent_pad_index)); \ - ((XPVNV*) MUTABLE_PTR(SvANY(_sv_parent_pad_index)))->xnv_u.xpad_cop_seq.xlow; \ - })) -# define PARENT_FAKELEX_FLAGS(sv) \ - (({ const SV *const _sv_parent_fakelex_flags = (const SV *) (sv); \ - assert(SvTYPE(_sv_parent_fakelex_flags) == SVt_NV \ - || SvTYPE(_sv_parent_fakelex_flags) >= SVt_PVNV); \ - assert(SvTYPE(_sv_parent_fakelex_flags) != SVt_PVAV); \ - assert(SvTYPE(_sv_parent_fakelex_flags) != SVt_PVHV); \ - assert(SvTYPE(_sv_parent_fakelex_flags) != SVt_PVCV); \ - assert(SvTYPE(_sv_parent_fakelex_flags) != SVt_PVFM); \ - assert(!isGV_with_GP(_sv_parent_fakelex_flags)); \ - ((XPVNV*) MUTABLE_PTR(SvANY(_sv_parent_fakelex_flags)))->xnv_u.xpad_cop_seq.xhigh; \ - })) -#else -# define COP_SEQ_RANGE_LOW(sv) \ - (0 + (((XPVNV*) SvANY(sv))->xnv_u.xpad_cop_seq.xlow)) -# define COP_SEQ_RANGE_HIGH(sv) \ - (0 + (((XPVNV*) SvANY(sv))->xnv_u.xpad_cop_seq.xhigh)) - - -# define PARENT_PAD_INDEX(sv) \ - (0 + (((XPVNV*) SvANY(sv))->xnv_u.xpad_cop_seq.xlow)) -# define PARENT_FAKELEX_FLAGS(sv) \ - (0 + (((XPVNV*) SvANY(sv))->xnv_u.xpad_cop_seq.xhigh)) -#endif +#define COP_SEQ_RANGE_LOW(pn) (pn)->xpadn_low +#define COP_SEQ_RANGE_HIGH(pn) (pn)->xpadn_high +#define PARENT_PAD_INDEX(pn) (pn)->xpadn_low +#define PARENT_FAKELEX_FLAGS(pn) (pn)->xpadn_high /* Flags set in the SvIVX field of FAKE namesvs */ @@ -236,8 +206,7 @@ The length of the name. Whether PadnamePV is in UTF8. Currently, this is always true. =for apidoc Amx|SV *|PadnameSV|PADNAME pn -Returns the pad name as an SV. This is currently just C<pn>. It will -begin returning a new mortal SV if pad names ever stop being SVs. +Returns the pad name as a mortal SV. =for apidoc m|bool|PadnameIsOUR|PADNAME pn Whether this is an "our" variable. @@ -256,6 +225,12 @@ Whether this is a "state" variable. The stash associated with a typed lexical. This returns the %Foo:: hash for C<my Foo $bar>. +=for apidoc Amx|SSize_t|PadnameREFCNT|PADNAME pn +The reference count of the pad name. + +=for apidoc Amx|void|PadnameREFCNT_dec|PADNAME pn +Lowers the reference count of the pad name. + =for apidoc m|SV *|PAD_SETSV |PADOFFSET po|SV* sv Set the slot at offset C<po> in the current pad to C<sv> @@ -313,19 +288,45 @@ Restore the old pad saved into the local variable opad by PAD_SAVE_LOCAL() #define PadARRAY(pad) AvARRAY(pad) #define PadMAX(pad) AvFILLp(pad) -#define PadnamePV(pn) (SvPOKp(pn) ? SvPVX_const(pn) : NULL) -#define PadnameLEN(pn) ((SV*)(pn) == &PL_sv_undef ? 0 : SvCUR(pn)) -#define PadnameUTF8(pn) (assert_(SvUTF8(pn)) 1) -#define PadnameSV(pn) pn -#define PadnameIsOUR(pn) !!SvPAD_OUR(pn) -#define PadnameOURSTASH(pn) SvOURSTASH(pn) -#define PadnameOUTER(pn) !!SvFAKE(pn) -#define PadnameIsSTATE(pn) !!SvPAD_STATE(pn) -#define PadnameTYPE(pn) (SvPAD_TYPED(pn) ? SvSTASH(pn) : NULL) -#define PadnameLVALUE(pn) \ - ((SvFLAGS(pn) & (SVpad_NAME|SVpad_LVALUE))==(SVpad_NAME|SVpad_LVALUE)) - -#define PadnameLVALUE_on(pn) (SvFLAGS(pn) |= SVpad_NAME|SVpad_LVALUE) +#define PadnamePV(pn) (pn)->xpadn_pv +#define PadnameLEN(pn) (pn)->xpadn_len +#define PadnameUTF8(pn) 1 +#define PadnameSV(pn) \ + newSVpvn_flags(PadnamePV(pn), PadnameLEN(pn), SVs_TEMP|SVf_UTF8) +#define PadnameFLAGS(pn) (pn)->xpadn_flags +#define PadnameIsOUR(pn) (!!(pn)->xpadn_ourstash) +#define PadnameOURSTASH(pn) (pn)->xpadn_ourstash +#define PadnameTYPE(pn) (pn)->xpadn_type_u.xpadn_typestash +#define PadnamePROTOCV(pn) (pn)->xpadn_type_u.xpadn_protocv +#define PadnameREFCNT(pn) (pn)->xpadn_refcnt +#define PadnameREFCNT_dec(pn) Perl_padname_free(aTHX_ pn) +#define PadnameOURSTASH_set(pn,s) (PadnameOURSTASH(pn) = (s)) +#define PadnameTYPE_set(pn,s) (PadnameTYPE(pn) = (s)) +#define PadnameOUTER(pn) (PadnameFLAGS(pn) & PADNAMEt_OUTER) +#define PadnameIsSTATE(pn) (PadnameFLAGS(pn) & PADNAMEt_STATE) +#define PadnameLVALUE(pn) (PadnameFLAGS(pn) & PADNAMEt_LVALUE) + +#define PadnameLVALUE_on(pn) (PadnameFLAGS(pn) |= PADNAMEt_LVALUE) +#define PadnameIsSTATE_on(pn) (PadnameFLAGS(pn) |= PADNAMEt_STATE) + +#define PADNAMEt_OUTER 1 /* outer lexical var */ +#define PADNAMEt_STATE 2 /* state var */ +#define PADNAMEt_LVALUE 4 /* used as lvalue */ +#define PADNAMEt_TYPED 8 /* for B; unused by core */ +#define PADNAMEt_OUR 16 /* for B; unused by core */ + +/* backward compatibility */ +#define SvPAD_STATE PadnameIsSTATE +#define SvPAD_TYPED(pn) (!!PadnameTYPE(pn)) +#define SvPAD_OUR(pn) (!!PadnameOURSTASH(pn)) +#define SvPAD_STATE_on PadnameIsSTATE_on +#define SvPAD_TYPED_on(pn) (PadnameFLAGS(pn) |= PADNAMEt_TYPED) +#define SvPAD_OUR_on(pn) (PadnameFLAGS(pn) |= PADNAMEt_OUR) +#define SvOURSTASH PadnameOURSTASH +#define SvOURSTASH_set PadnameOURSTASH_set +#define SVpad_STATE PADNAMEt_STATE +#define SVpad_TYPED PADNAMEt_TYPED +#define SVpad_OUR PADNAMEt_OUR #ifdef DEBUGGING # define PAD_SV(po) pad_sv(po) @@ -423,7 +424,7 @@ ling pad (lvalue) to C<gen>. Note that C<SvUV_set> is hijacked for this purpose #define PAD_COMPNAME(po) PAD_COMPNAME_SV(po) #define PAD_COMPNAME_SV(po) (PadnamelistARRAY(PL_comppad_name)[(po)]) -#define PAD_COMPNAME_FLAGS(po) SvFLAGS(PAD_COMPNAME_SV(po)) +#define PAD_COMPNAME_FLAGS(po) PadnameFLAGS(PAD_COMPNAME(po)) #define PAD_COMPNAME_FLAGS_isOUR(po) SvPAD_OUR(PAD_COMPNAME_SV(po)) #define PAD_COMPNAME_PV(po) PadnamePV(PAD_COMPNAME(po)) @@ -433,10 +434,10 @@ ling pad (lvalue) to C<gen>. Note that C<SvUV_set> is hijacked for this purpose (SvOURSTASH(PAD_COMPNAME_SV(po))) #define PAD_COMPNAME_GEN(po) \ - ((STRLEN)SvUVX(PadnamelistARRAY(PL_comppad_name)[po])) + ((STRLEN)PadnamelistARRAY(PL_comppad_name)[po]->xpadn_gen) #define PAD_COMPNAME_GEN_set(po, gen) \ - SvUV_set(PadnamelistARRAY(PL_comppad_name)[po], (UV)(gen)) + (PadnamelistARRAY(PL_comppad_name)[po]->xpadn_gen = (gen)) /* @@ -2652,12 +2652,12 @@ typedef struct ptr_tbl_ent PTR_TBL_ENT_t; typedef struct ptr_tbl PTR_TBL_t; typedef struct clone_params CLONE_PARAMS; -/* a pad or name pad is currently just an AV; but that might change, +/* a pad is currently just an AV; but that might change, * so hide the type. */ typedef struct padlist PADLIST; typedef AV PAD; typedef struct padnamelist PADNAMELIST; -typedef SV PADNAME; +typedef struct padname PADNAME; /* enable PERL_NEW_COPY_ON_WRITE by default */ #if !defined(PERL_OLD_COPY_ON_WRITE) && !defined(PERL_NEW_COPY_ON_WRITE) && !defined(PERL_NO_COW) @@ -3407,8 +3407,8 @@ typedef pthread_key_t perl_key; #endif #define UTF8fARG(u,l,p) (int)cBOOL(u), (UV)(l), (void*)(p) -#define PNf SVf -#define PNfARG SVfARG +#define PNf UTF8f +#define PNfARG(pn) (int)1, (UV)PadnameLEN(pn), (void *)PadnamePV(pn) #ifdef PERL_CORE /* not used; but needed for backward compatibility with XS code? - RMB */ @@ -170,25 +170,24 @@ PP(pp_introcv) PP(pp_clonecv) { dTARGET; - MAGIC * const mg = - mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG], - PERL_MAGIC_proto); + CV * const protocv = PadnamePROTOCV( + PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG] + ); assert(SvTYPE(TARG) == SVt_PVCV); - assert(mg); - assert(mg->mg_obj); - if (CvISXSUB(mg->mg_obj)) { /* constant */ + assert(protocv); + if (CvISXSUB(protocv)) { /* constant */ /* XXX Should we clone it here? */ /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV to introcv and remove the SvPADSTALE_off. */ SAVEPADSVANDMORTALIZE(ARGTARG); - PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(mg->mg_obj); + PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv); } else { - if (CvROOT(mg->mg_obj)) { - assert(CvCLONE(mg->mg_obj)); - assert(!CvCLONED(mg->mg_obj)); + if (CvROOT(protocv)) { + assert(CvCLONE(protocv)); + assert(!CvCLONED(protocv)); } - cv_clone_into((CV *)mg->mg_obj,(CV *)TARG); + cv_clone_into(protocv,(CV *)TARG); SAVECLEARSV(PAD_SVl(ARGTARG)); } return NORMAL; @@ -2985,6 +2985,20 @@ PERL_CALLCONV PADNAMELIST * Perl_newPADNAMELIST(pTHX_ size_t max) __attribute__malloc__ __attribute__warn_unused_result__; +PERL_CALLCONV PADNAME * Perl_newPADNAMEouter(pTHX_ PADNAME *outer) + __attribute__malloc__ + __attribute__warn_unused_result__ + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_NEWPADNAMEOUTER \ + assert(outer) + +PERL_CALLCONV PADNAME * Perl_newPADNAMEpvn(pTHX_ const char *s, STRLEN len) + __attribute__malloc__ + __attribute__warn_unused_result__ + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_NEWPADNAMEPVN \ + assert(s) + PERL_CALLCONV OP* Perl_newPMOP(pTHX_ I32 type, I32 flags) __attribute__malloc__ __attribute__warn_unused_result__; @@ -3353,6 +3367,11 @@ PERL_CALLCONV PAD ** Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *va #define PERL_ARGS_ASSERT_PADLIST_STORE \ assert(padlist) +PERL_CALLCONV void Perl_padname_free(pTHX_ PADNAME *pn) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_PADNAME_FREE \ + assert(pn) + PERL_CALLCONV PADNAME * Perl_padnamelist_fetch(pTHX_ PADNAMELIST *pnl, SSize_t key) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); @@ -8038,6 +8057,13 @@ PERL_CALLCONV PADLIST * Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *pa #define PERL_ARGS_ASSERT_PADLIST_DUP \ assert(srcpad); assert(param) +PERL_CALLCONV PADNAME * Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param) + __attribute__warn_unused_result__ + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_PADNAME_DUP \ + assert(src); assert(param) + PERL_CALLCONV PADNAMELIST * Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) @@ -972,6 +972,9 @@ Perl_leave_scope(pTHX_ I32 base) case SAVEt_FREESV: SvREFCNT_dec(ARG0_SV); break; + case SAVEt_FREEPADNAME: + PadnameREFCNT_dec((PADNAME *)ARG0_PTR); + break; case SAVEt_FREECOPHH: cophh_free((COPHH *)ARG0_PTR); break; @@ -39,12 +39,12 @@ #define SAVEt_PARSER 19 #define SAVEt_STACK_POS 20 #define SAVEt_READONLY_OFF 21 +#define SAVEt_FREEPADNAME 22 -#define SAVEt_ARG1_MAX 21 +#define SAVEt_ARG1_MAX 22 /* two args */ -#define SAVEt_APTR 22 #define SAVEt_AV 23 #define SAVEt_DESTRUCTOR 24 #define SAVEt_DESTRUCTOR_X 25 @@ -69,17 +69,19 @@ #define SAVEt_SVREF 44 #define SAVEt_VPTR 45 #define SAVEt_ADELETE 46 +#define SAVEt_APTR 47 -#define SAVEt_ARG2_MAX 46 +#define SAVEt_ARG2_MAX 47 /* three args */ -#define SAVEt_DELETE 47 #define SAVEt_HELEM 48 #define SAVEt_PADSV_AND_MORTALIZE 49 #define SAVEt_SET_SVFLAGS 50 #define SAVEt_GVSLOT 51 #define SAVEt_AELEM 52 +#define SAVEt_DELETE 53 + #define SAVEf_SETMAGIC 1 #define SAVEf_KEEPOLDELEM 2 @@ -240,6 +242,7 @@ scope has the given name. Name must be a literal string. #define SAVEVPTR(s) save_vptr((void*)&(s)) #define SAVEPADSVANDMORTALIZE(s) save_padsv_and_mortalize(s) #define SAVEFREESV(s) save_freesv(MUTABLE_SV(s)) +#define SAVEFREEPADNAME(s) save_pushptr((void *)(s), SAVEt_FREEPADNAME) #define SAVEMORTALIZESV(s) save_mortalizesv(MUTABLE_SV(s)) #define SAVEFREEOP(o) save_freeop((OP*)(o)) #define SAVEFREEPV(p) save_freepv((char*)(p)) @@ -638,8 +638,6 @@ do_curse(pTHX_ SV * const sv) { if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv) || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv)) return; - if (SvPAD_NAME(sv)) - return; (void)curse(sv, 0); } @@ -1332,10 +1330,6 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) there's no way that it can be safely upgraded, because perl.c expects to Safefree(SvANY(PL_mess_sv)) */ assert(sv != PL_mess_sv); - /* This flag bit is used to mean other things in other scalar types. - Given that it only has meaning inside the pad, it shouldn't be set - on anything that can get upgraded. */ - assert(!SvPAD_TYPED(sv)); break; default: if (UNLIKELY(old_type_details->cant_upgrade)) @@ -6493,10 +6487,10 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) /* objs are always >= MG, but pad names use the SVs_OBJECT flag for another purpose */ - assert(!SvOBJECT(sv) || type >= SVt_PVMG || SvPAD_NAME(sv)); + assert(!SvOBJECT(sv) || type >= SVt_PVMG); if (type >= SVt_PVMG) { - if (SvOBJECT(sv) && !SvPAD_NAME(sv)) { + if (SvOBJECT(sv)) { if (!curse(sv, 1)) goto get_next_sv; type = SvTYPE(sv); /* destructor may have changed it */ } @@ -6507,16 +6501,12 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) if (SvMAGIC(sv)) mg_free(sv); } - else if (type == SVt_PVMG && SvPAD_OUR(sv)) { - SvREFCNT_dec(SvOURSTASH(sv)); - } else if (SvMAGIC(sv)) { + else if (SvMAGIC(sv)) { /* Free back-references before other types of magic. */ sv_unmagic(sv, PERL_MAGIC_backref); mg_free(sv); } SvMAGICAL_off(sv); - if (type == SVt_PVMG && SvPAD_TYPED(sv)) - SvREFCNT_dec(SvSTASH(sv)); } switch (type) { /* case SVt_INVLIST: */ @@ -13402,7 +13392,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) #endif /* don't clone objects whose class has asked us not to */ - if (SvOBJECT(sstr) && !SvPAD_NAME(sstr) + if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) { SvFLAGS(dstr) = 0; @@ -13489,11 +13479,9 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) missing by always going for the destination. FIXME - instrument and check that assumption */ if (sv_type >= SVt_PVMG) { - if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) { - SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param)); - } else if (SvMAGIC(dstr)) + if (SvMAGIC(dstr)) SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param)); - if (SvOBJECT(dstr) && !SvPAD_NAME(dstr) && SvSTASH(dstr)) + if (SvOBJECT(dstr) && SvSTASH(dstr)) SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param)); else SvSTASH_set(dstr, 0); /* don't copy DESTROY cache */ } @@ -14007,6 +13995,11 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); break; + case SAVEt_FREEPADNAME: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = padname_dup((PADNAME *)ptr, param); + PadnameREFCNT((PADNAME *)TOPPTR(nss,ix))++; + break; case SAVEt_SHARED_PVREF: /* char* in shared space */ c = (char*)POPPTR(ss,ix); TOPPTR(nss,ix) = savesharedpv(c); @@ -14376,6 +14369,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_sig_pending = 0; PL_parser = NULL; Zero(&PL_debug_pad, 1, struct perl_debug_pad); + Zero(&PL_padname_undef, 1, PADNAME); + Zero(&PL_padname_const, 1, PADNAME); # ifdef DEBUG_LEAKING_SCALARS PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000; # endif @@ -14656,6 +14651,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef); ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no); ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes); + ptr_table_store(PL_ptr_table, &proto_perl->Ipadname_const, + &PL_padname_const); /* create (a non-shared!) shared string table */ PL_strtab = newHV(); @@ -15166,6 +15163,8 @@ Perl_init_constants(pTHX) SvLEN_set(&PL_sv_yes, 0); SvIV_set(&PL_sv_yes, 1); SvNV_set(&PL_sv_yes, 1); + + PadnamePV(&PL_padname_const) = (char *)PL_No; } /* @@ -15403,14 +15402,15 @@ Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, } else { CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL); - SV *sv; + PADNAME *sv; assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); if (!cv || !CvPADLIST(cv)) return NULL; sv = padnamelist_fetch(PadlistNAMES(CvPADLIST(cv)), targ); - sv_setsv_flags(name, sv, 0); + sv_setpvn(name, PadnamePV(sv), PadnameLEN(sv)); + SvUTF8_on(name); } if (subscript_type == FUV_SUBSCRIPT_HASH) { @@ -373,13 +373,10 @@ perform the upgrade if necessary. See C<svtype>. expanded to a real GV */ #define SVf_PROTECT 0x00010000 /* very read-only */ #define SVs_PADTMP 0x00020000 /* in use as tmp */ -#define SVpad_TYPED 0x00020000 /* pad name is a Typed Lexical */ #define SVs_PADSTALE 0x00040000 /* lexical has gone out of scope; only used when !PADTMP */ -#define SVpad_OUR 0x00040000 /* pad name is "our" instead of "my" */ #define SVs_TEMP 0x00080000 /* mortal (implies string is stealable) */ #define SVs_OBJECT 0x00100000 /* is "blessed" */ -#define SVpad_LVALUE 0x00100000 /* pad name is used as lvalue */ #define SVs_GMG 0x00200000 /* has magical get method */ #define SVs_SMG 0x00400000 /* has magical set method */ #define SVs_RMG 0x00800000 /* has random magical methods */ @@ -389,10 +386,7 @@ perform the upgrade if necessary. See C<svtype>. 2: For PVCV, whether CvUNIQUE(cv) refers to an eval or once only [CvEVAL(cv), CvSPECIAL(cv)] - 3: On a pad name SV, that slot in the - frame AV is a REFCNT'ed reference - to a lexical from "outside". - 4: HV: informally reserved by DAPM + 3: HV: informally reserved by DAPM for vtables */ #define SVf_OOK 0x02000000 /* has valid offset value. For a PVHV this means that a hv_aux struct is present @@ -436,22 +430,19 @@ perform the upgrade if necessary. See C<svtype>. /* Some private flags. */ -/* PVNV, PVMG only, and only used in pads. Should be safe to test on any scalar - SV, as the core is careful to avoid setting both. +/* The SVp_SCREAM|SVpbm_VALID (0x40008000) combination is up for grabs. + Formerly it was used for pad names, but now it is available. The core + is careful to avoid setting both flags. SVf_POK, SVp_POK also set: 0x00004400 Normal 0x0000C400 method name for DOES (SvSCREAM) 0x40004400 FBM compiled (SvVALID) - 0x4000C400 pad name. + 0x4000C400 *** Formerly used for pad names *** 0x00008000 GV with GP 0x00008800 RV with PCS imported */ -#define SVpad_NAME (SVp_SCREAM|SVpbm_VALID) - /* This SV is a name in the PAD, so - SVpad_TYPED, SVpad_OUR and SVpad_STATE - apply */ /* PVAV */ #define SVpav_REAL 0x40000000 /* free old entries */ /* PVHV */ @@ -473,7 +464,6 @@ perform the upgrade if necessary. See C<svtype>. /* RV upwards. However, SVf_ROK and SVp_IOK are exclusive */ #define SVprv_WEAKREF 0x80000000 /* Weak reference */ /* pad name vars only */ -#define SVpad_STATE 0x80000000 /* pad name is a "state" var */ #define _XPV_HEAD \ HV* xmg_stash; /* class package */ \ @@ -503,7 +493,6 @@ union _xivu { union _xmgu { MAGIC* xmg_magic; /* linked list of magicalness */ - HV* xmg_ourstash; /* Stash for our (when SvPAD_OUR is true) */ STRLEN xmg_hash_index; /* used while freeing hash entries */ }; @@ -1143,47 +1132,6 @@ sv_force_normal does nothing. #define SvTAIL_on(sv) (SvFLAGS(sv) |= SVpbm_TAIL) #define SvTAIL_off(sv) (SvFLAGS(sv) &= ~SVpbm_TAIL) -#define SvPAD_NAME(sv) ((SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) - -#define SvPAD_TYPED(sv) \ - ((SvFLAGS(sv) & (SVpad_NAME|SVpad_TYPED)) == (SVpad_NAME|SVpad_TYPED)) - -#define SvPAD_OUR(sv) \ - ((SvFLAGS(sv) & (SVpad_NAME|SVpad_OUR)) == (SVpad_NAME|SVpad_OUR)) - -#define SvPAD_STATE(sv) \ - ((SvFLAGS(sv) & (SVpad_NAME|SVpad_STATE)) == (SVpad_NAME|SVpad_STATE)) - -#if defined (DEBUGGING) && defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) -# define SvPAD_TYPED_on(sv) ({ \ - SV *const _svpad = MUTABLE_SV(sv); \ - assert(SvTYPE(_svpad) == SVt_PVMG); \ - (SvFLAGS(_svpad) |= SVpad_NAME|SVpad_TYPED); \ - }) -#define SvPAD_OUR_on(sv) ({ \ - SV *const _svpad = MUTABLE_SV(sv); \ - assert(SvTYPE(_svpad) == SVt_PVMG); \ - (SvFLAGS(_svpad) |= SVpad_NAME|SVpad_OUR); \ - }) -#define SvPAD_STATE_on(sv) ({ \ - SV *const _svpad = MUTABLE_SV(sv); \ - assert(SvTYPE(_svpad) == SVt_PVNV || SvTYPE(_svpad) == SVt_PVMG); \ - (SvFLAGS(_svpad) |= SVpad_NAME|SVpad_STATE); \ - }) -#else -# define SvPAD_TYPED_on(sv) (SvFLAGS(sv) |= SVpad_NAME|SVpad_TYPED) -# define SvPAD_OUR_on(sv) (SvFLAGS(sv) |= SVpad_NAME|SVpad_OUR) -# define SvPAD_STATE_on(sv) (SvFLAGS(sv) |= SVpad_NAME|SVpad_STATE) -#endif - -#define SvOURSTASH(sv) \ - (SvPAD_OUR(sv) ? ((XPVMG*) SvANY(sv))->xmg_u.xmg_ourstash : NULL) -#define SvOURSTASH_set(sv, st) \ - STMT_START { \ - assert(SvTYPE(sv) == SVt_PVMG); \ - ((XPVMG*) SvANY(sv))->xmg_u.xmg_ourstash = st; \ - } STMT_END - #define SvRVx(sv) SvRV(sv) #ifdef PERL_DEBUG_COW @@ -1266,8 +1214,6 @@ sv_force_normal does nothing. # define SvMAGIC(sv) \ (*({ const SV *const _svmagic = (const SV *)(sv); \ assert(SvTYPE(_svmagic) >= SVt_PVMG); \ - if(SvTYPE(_svmagic) == SVt_PVMG) \ - assert(!SvPAD_OUR(_svmagic)); \ &(((XPVMG*) MUTABLE_PTR(SvANY(_svmagic)))->xmg_u.xmg_magic); \ })) # define SvSTASH(sv) \ @@ -2204,14 +2150,12 @@ C<SvUTF8_on> on the new SV. Implemented as a wrapper around C<newSVpvn_flags>. /* =for apidoc Amx|SV*|newSVpadname|PADNAME *pn -Creates a new SV containing the pad name. This is currently identical -to C<newSVsv>, but pad names may cease being SVs at some point, so -C<newSVpadname> is preferable. +Creates a new SV containing the pad name. =cut */ -#define newSVpadname(pn) newSVsv((SV *)(pn)) +#define newSVpadname(pn) newSVpvn_utf8(PadnamePV(pn), PadnameLEN(pn), TRUE) /* =for apidoc Am|void|SvOOK_offset|NN SV*sv|STRLEN len |