[prev in list] [next in list] [prev in thread] [next in thread]
List: perl5-changes
Subject: [perl.git] branch sprout/pn, updated. v5.21.6-42-g54b24c8
From: Father Chrysostomos <sprout () cpan ! org>
Date: 2014-11-26 0:33:46
Message-ID: E1XtQYE-0004v3-OS () camel-001 ! ams6 ! corp ! booking ! com
[Download RAW message or body]
In perl.git, the branch sprout/pn has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/54b24c88eea2cc30f0e00b11bf29a83389c737dc?hp=b9dc24b126c1b98ee9cbf76c1cda55bada5e4f87>
- Log -----------------------------------------------------------------
commit 54b24c88eea2cc30f0e00b11bf29a83389c737dc
Author: Father Chrysostomos <sprout@cpan.org>
Date: Tue Nov 25 16:33:35 2014 -0800
Make PADNAME a separate type — WIP
B::Deparse is completely broken.
-----------------------------------------------------------------------
Summary of changes:
dump.c | 33 +----
embed.fnc | 4 +
embed.h | 3 +
embedvar.h | 2 +
intrpvar.h | 2 +
mg_names.c | 1 -
mg_raw.h | 2 -
mg_vtable.h | 1 -
op.c | 43 +++---
pad.c | 389 ++++++++++++++++++++++++++++++++++-------------------
pad.h | 158 +++++++++++-----------
perl.h | 7 +-
pod/perlguts.pod | 1 -
pp.c | 21 ++-
proto.h | 26 ++++
regen/mg_vtable.pl | 1 -
scope.c | 3 +
scope.h | 11 +-
sv.c | 40 +++---
sv.h | 65 +--------
t/porting/diag.t | 3 +-
21 files changed, 444 insertions(+), 372 deletions(-)
diff --git a/dump.c b/dump.c
index 0c55b5d..f4dd778 100644
--- a/dump.c
+++ b/dump.c
@@ -1430,15 +1430,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,");
@@ -1488,11 +1483,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;
@@ -1561,13 +1552,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) {
@@ -1637,14 +1622,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));
@@ -2294,7 +2273,7 @@ Perl_debop(pTHX_ const OP *o)
/* print the lexical's name */
{
CV * const cv = deb_curcv(cxstack_ix);
- SV *sv;
+ PADNAME *sv;
PADNAMELIST * comppad = NULL;
int i;
@@ -2306,7 +2285,7 @@ Perl_debop(pTHX_ const OP *o)
for (i = 0; i < count; i++) {
if (comppad &&
(sv = padnamelist_fetch(comppad, o->op_targ + i)))
- PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
+ PerlIO_printf(Perl_debug_log, "%"PNf, PNfARG(sv));
else
PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
(UV)o->op_targ+i);
diff --git a/embed.fnc b/embed.fnc
index b5fc669..ccc4628 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -999,6 +999,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
@@ -2587,7 +2589,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 \
diff --git a/embed.h b/embed.h
index c5525cf..6d5a7d3 100644
--- a/embed.h
+++ b/embed.h
@@ -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/embedvar.h b/embedvar.h
index 2a3ebdc..712c259 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -230,6 +230,8 @@
#define PL_pad_reset_pending (vTHX->Ipad_reset_pending)
#define PL_padix (vTHX->Ipadix)
#define PL_padix_floor (vTHX->Ipadix_floor)
+#define PL_padname_const (vTHX->Ipadname_const)
+#define PL_padname_undef (vTHX->Ipadname_undef)
#define PL_parser (vTHX->Iparser)
#define PL_patchlevel (vTHX->Ipatchlevel)
#define PL_peepp (vTHX->Ipeepp)
diff --git a/intrpvar.h b/intrpvar.h
index 56bb5c4..6397eb6 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -146,6 +146,8 @@ C<&PL_sv_yes>.
PERLVAR(I, sv_undef, SV)
PERLVAR(I, sv_no, SV)
PERLVAR(I, sv_yes, SV)
+PERLVAR(I, padname_undef, PADNAME)
+PERLVAR(I, padname_const, PADNAME)
PERLVAR(I, Sv, SV *) /* used to hold temporary values */
PERLVAR(I, parser, yy_parser *) /* current parser state */
diff --git a/mg_names.c b/mg_names.c
index 237dfc5..57d52db 100644
--- a/mg_names.c
+++ b/mg_names.c
@@ -9,7 +9,6 @@
{ PERL_MAGIC_sv, "sv(\\0)" },
{ PERL_MAGIC_arylen, "arylen(#)" },
{ PERL_MAGIC_rhash, "rhash(%)" },
- { PERL_MAGIC_proto, "proto(&)" },
{ PERL_MAGIC_debugvar, "debugvar(*)" },
{ PERL_MAGIC_pos, "pos(.)" },
{ PERL_MAGIC_symtab, "symtab(:)" },
diff --git a/mg_raw.h b/mg_raw.h
index fd4a826..b3e25d6 100644
--- a/mg_raw.h
+++ b/mg_raw.h
@@ -12,8 +12,6 @@
"/* arylen '#' Array length ($#ary) */" },
{ '%', "magic_vtable_max | PERL_MAGIC_VALUE_MAGIC",
"/* rhash '%' Extra data for restricted hashes */" },
- { '&', "magic_vtable_max",
- "/* proto '&' my sub prototype CV */" },
{ '*', "want_vtbl_debugvar",
"/* debugvar '*' $DB::single, signal, trace vars */" },
{ '.', "want_vtbl_pos | PERL_MAGIC_VALUE_MAGIC",
diff --git a/mg_vtable.h b/mg_vtable.h
index c0bb820..c71a988 100644
--- a/mg_vtable.h
+++ b/mg_vtable.h
@@ -15,7 +15,6 @@
#define PERL_MAGIC_sv '\0' /* Special scalar variable */
#define PERL_MAGIC_arylen '#' /* Array length ($#ary) */
#define PERL_MAGIC_rhash '%' /* Extra data for restricted hashes */
-#define PERL_MAGIC_proto '&' /* my sub prototype CV */
#define PERL_MAGIC_debugvar '*' /* $DB::single, signal, trace vars */
#define PERL_MAGIC_pos '.' /* pos() lvalue */
#define PERL_MAGIC_symtab ':' /* Extra data for symbol tables */
diff --git a/op.c b/op.c
index 4d6f1d0..a285e10 100644
--- a/op.c
+++ b/op.c
@@ -2234,7 +2234,7 @@ S_finalize_op(pTHX_ OP* o)
case OP_HELEM: {
UNOP *rop;
- SV *lexname;
+ PADNAME *lexname;
GV **fields;
SVOP *key_op;
OP *kid;
@@ -2290,7 +2290,8 @@ S_finalize_op(pTHX_ OP* o)
rop
&& (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
SvPAD_TYPED(lexname))
- && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
+ && (fields =
+ (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
&& isGV(*fields) && GvHV(*fields);
for (; key_op;
key_op = (SVOP*)OP_SIBLING(key_op)) {
@@ -2313,9 +2314,9 @@ S_finalize_op(pTHX_ OP* o)
if (check_fields
&& !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
- "in variable %"SVf" of type %"HEKf,
- SVfARG(*svp), SVfARG(lexname),
- HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
+ "in variable %"PNf" of type %"HEKf,
+ SVfARG(*svp), PNfARG(lexname),
+ HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
}
}
break;
@@ -2808,8 +2809,8 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
case OP_PADSV:
PL_modcount++;
if (!type) /* local() */
- Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
- PAD_COMPNAME_SV(o->op_targ));
+ Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
+ PNfARG(PAD_COMPNAME(o->op_targ)));
if (!(o->op_private & OPpLVAL_INTRO)
|| ( type != OP_SASSIGN && type != OP_AASSIGN
&& PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
@@ -7763,7 +7764,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;
@@ -7876,7 +7877,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP \
*block) spot = (CV **)svspot;
if (!(PL_parser && PL_parser->error_count))
- move_proto_attr(&proto, &attrs, (GV *)name);
+ move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
if (proto) {
assert(proto->op_type == OP_CONST);
@@ -7905,9 +7906,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);
@@ -7924,15 +7922,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) {
@@ -7967,7 +7958,8 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP \
*block)
* skipping the prototype check
*/
if (exists || SvPOK(cv))
- cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
+ cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
+ ps_utf8);
/* already defined? */
if (exists) {
if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
@@ -10966,11 +10958,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];
}
diff --git a/pad.c b/pad.c
index 65365ff..d3c06ca 100644
--- a/pad.c
+++ b/pad.c
@@ -59,12 +59,13 @@ AV which is @_. Other entries are storage for variables and op \
targets.
Iterating over the PADNAMELIST iterates over all possible pad
items. Pad slots for targets (SVs_PADTMP)
-and GVs end up having &PL_sv_undef
-"names", while slots for constants have &PL_sv_no "names" (see
-pad_alloc()). That &PL_sv_no is used is an implementation detail subject
-to change. To test for it, use C<PadnamePV(name) && !PadnameLEN(name)>.
+and GVs end up having &PL_padname_undef "names", while slots for constants
+have &PL_padname_const "names" (see pad_alloc()). That &PL_padname_undef
+and &PL_padname_const are used is an implementation detail subject to
+change. To test for them, use C<!PadnamePV(name)> and C<PadnamePV(name)
+&& !PadnameLEN(name)>, respectively.
-Only my/our variable (SvPADMY/PADNAME_isOUR) slots get valid names.
+Only my/our variable slots get valid names.
The rest are op targets/GVs/constants which are statically allocated
or resolved at compile time. These don't have names by which they
can be looked up from Perl code at run time through eval"" the way
@@ -72,10 +73,10 @@ my/our variables can be. Since they can't be looked up by "name"
but only by their index allocated at compile time (which is usually
in PL_op->op_targ), wasting a name SV for them doesn't make sense.
-The SVs in the names AV have their PV being the name of the variable.
-xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
-which the name is valid (accessed through the macros COP_SEQ_RANGE_LOW and
-_HIGH). During compilation, these fields may hold the special value
+The pad names in the PADNAMELIST have their PV holding the name of
+the variable. The COP_SEQ_RANGE_LOW and _HIGH fields form a range
+(low+1..high inclusive) of cop_seq numbers for which the name is
+valid. During compilation, these fields may hold the special value
PERL_PADSEQ_INTRO to indicate various stages:
COP_SEQ_RANGE_LOW _HIGH
@@ -84,27 +85,24 @@ PERL_PADSEQ_INTRO to indicate various stages:
valid-seq# PERL_PADSEQ_INTRO variable in scope: { my ($x)
valid-seq# valid-seq# compilation of scope complete: { my ($x) }
-For typed lexicals name SV is SVt_PVMG and SvSTASH
-points at the type. For C<our> lexicals, the type is also SVt_PVMG, with the
-SvOURSTASH slot pointing at the stash of the associated global (so that
-duplicate C<our> declarations in the same package can be detected). SvUVX is
-sometimes hijacked to store the generation number during compilation.
+For typed lexicals PadnameTYPE points at the type stash. For C<our>
+lexicals, PadnameOURSTASH points at the stash of the associated global (so
+that duplicate C<our> declarations in the same package can be detected).
+PadnameGEN is sometimes used to store the generation number during
+compilation.
-If PADNAME_OUTER (SvFAKE) is set on the
-name SV, then that slot in the frame AV is
+If PadnameOUTER is set on the pad name, then that slot in the frame AV is
a REFCNT'ed reference to a lexical from "outside". In this case,
-the name SV does not use xlow and xhigh to store a cop_seq range, since it is
-in scope throughout. Instead xhigh stores some flags containing info about
+the name does not use 'low' and 'high' to store
+a cop_seq range, since it is in scope throughout.
+Instead 'high' stores some flags containing info about
the real lexical (is it declared in an anon, and is it capable of being
-instantiated multiple times?), and for fake ANONs, xlow contains the index
+instantiated multiple times?), and for fake ANONs, 'low' contains the index
within the parent's pad where the lexical's value is stored, to make
cloning quicker.
If the 'name' is '&' the corresponding entry in the PAD
is a CV representing a possible closure.
-(PADNAME_OUTER and name of '&' is not a
-meaningful combination currently but could
-become so if C<my sub foo {}> is implemented.)
Note that formats are treated as anon subs, and are cloned each time
write is called (if necessary).
@@ -116,7 +114,8 @@ to be generated in evals, such as
{ my $x = 1; sub f { eval '$x'} } f();
-For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'.
+For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised',
+but this internal state is stored in a separate pad entry.
=for apidoc AmxU|PADNAMELIST *|PL_comppad_name
@@ -146,14 +145,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
@@ -247,7 +244,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
@@ -406,13 +403,12 @@ Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
CV * const outercv = CvOUTSIDE(&cvbody);
const U32 seq = CvOUTSIDE_SEQ(&cvbody);
PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
- SV ** const namepad = PadnamelistARRAY(comppad_name);
+ PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
PAD * const comppad = PadlistARRAY(padlist)[1];
SV ** const curpad = AvARRAY(comppad);
for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
- SV * const namesv = namepad[ix];
- if (namesv && namesv != &PL_sv_undef
- && *SvPVX_const(namesv) == '&')
+ PADNAME * const name = namepad[ix];
+ if (name && PadnamePV(name) && *PadnamePV(name) == '&')
{
CV * const innercv = MUTABLE_CV(curpad[ix]);
U32 inner_rc = SvREFCNT(innercv);
@@ -531,14 +527,14 @@ Perl_cv_forget_slab(pTHX_ CV *cv)
}
/*
-=for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV \
*ourstash +=for apidoc m|PADOFFSET|pad_alloc_name|PADNAME *name|U32 flags|HV \
*typestash|HV *ourstash
Allocates a place in the currently-compiling
pad (via L<perlapi/pad_alloc>) and
-then stores a name for that entry. I<namesv> is adopted and becomes the
-name entry; it must already contain the name string and be sufficiently
-upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
-added to I<namesv>. None of the other
+then stores a name for that entry. I<name> is adopted and
+becomes the name entry; it must already contain the name
+string. I<typestash> and I<ourstash> and the C<padadd_STATE>
+flag get added to I<name>. None of the other
processing of L<perlapi/pad_add_name_pvn>
is done. Returns the offset of the allocated pad slot.
@@ -556,9 +552,8 @@ 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))));
+ SvTYPESTASH_set(name, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
}
if (ourstash) {
SvPAD_OUR_on(name);
@@ -569,7 +564,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;
}
@@ -608,18 +603,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;
}
@@ -754,8 +745,9 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
* stant or a target. For a target, things marked PADTMP
* can be reused; not so for constants.
*/
+ PADNAME *pn;
if (++retval <= names_fill &&
- (sv = names[retval]) && sv != &PL_sv_undef)
+ (pn = names[retval]) && PadnamePV(pn))
continue;
sv = *av_fetch(PL_comppad, retval, TRUE);
if (!(SvFLAGS(sv) &
@@ -768,7 +760,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;
}
@@ -810,16 +802,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[] ? */
@@ -859,7 +850,7 @@ C<is_our> indicates that the name to check is an 'our' \
declaration. STATIC void
S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash)
{
- SV **svp;
+ PADNAME **svp;
PADOFFSET top, off;
const U32 is_our = flags & padadd_OUR;
@@ -878,22 +869,22 @@ S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV \
*ourstash)
/* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
* type ? */
for (off = top; (I32)off > PL_comppad_name_floor; off--) {
- SV * const sv = svp[off];
+ PADNAME * const sv = svp[off];
if (sv
- && PadnameLEN(sv)
- && !SvFAKE(sv)
+ && PadnameLEN(sv) == PadnameLEN(name)
+ && !PadnameOUTER(sv)
&& ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
|| COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
- && sv_eq((SV *)name, sv))
+ && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
{
if (is_our && (SvPAD_OUR(sv)))
break; /* "our" masking "our" */
/* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
Perl_warner(aTHX_ packWARN(WARN_MISC),
- "\"%s\" %s %"SVf" masks earlier declaration in same %s",
+ "\"%s\" %s %"PNf" masks earlier declaration in same %s",
(is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
- *SvPVX(sv) == '&' ? "subroutine" : "variable",
- SVfARG(sv),
+ *PadnamePV(sv) == '&' ? "subroutine" : "variable",
+ PNfARG(sv),
(COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
? "scope" : "statement"));
--off;
@@ -903,17 +894,17 @@ S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV \
*ourstash) /* check the rest of the pad */
if (is_our) {
while (off > 0) {
- SV * const sv = svp[off];
+ PADNAME * const sv = svp[off];
if (sv
- && PadnameLEN(sv)
- && !SvFAKE(sv)
+ && PadnameLEN(sv) == PadnameLEN(name)
+ && !PadnameOUTER(sv)
&& ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
|| COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
&& SvOURSTASH(sv) == ourstash
- && sv_eq((SV *)name, sv))
+ && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
{
Perl_warner(aTHX_ packWARN(WARN_MISC),
- "\"our\" variable %"SVf" redeclared", SVfARG(sv));
+ "\"our\" variable %"PNf" redeclared", PNfARG(sv));
if ((I32)off <= PL_comppad_name_floor)
Perl_warner(aTHX_ packWARN(WARN_MISC),
"\t(Did you mean \"local\" instead of \"our\"?)\n");
@@ -1098,13 +1089,13 @@ to match against. If warn is true, print appropriate \
warnings. The out_* vars return values, and so are pointers to where the returned \
values should be stored. out_capture, if non-null, requests that the innermost
instance of the lexical is captured; out_name is set to the innermost
-matched namesv or fake namesv; out_flags returns the flags normally
-associated with the IVX field of a fake namesv.
+matched pad name or fake pad name; out_flags returns the flags normally
+associated with the PARENT_FAKELEX_FLAGS field of a fake pad name.
Note that pad_findlex() is recursive; it recurses up the chain of CVs,
then comes back down, adding fake entries
as it goes. It has to be this way
-because fake namesvs in anon protoypes have to store in xlow the index into
+because fake names in anon protoypes have to store in xlow the index into
the parent pad.
=cut
@@ -1118,15 +1109,15 @@ the parent pad.
#define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
static void
-S_unavailable(pTHX_ SV *namesv)
+S_unavailable(pTHX_ PADNAME *name)
{
/* diag_listed_as: Variable "%s" is not available */
Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
- "%se \"%"SVf"\" is not available",
- *SvPVX_const(namesv) == '&'
+ "%se \"%"PNf"\" is not available",
+ *PadnamePV(name) == '&'
? "Subroutin"
: "Variabl",
- SVfARG(namesv));
+ PNfARG(name));
}
STATIC PADOFFSET
@@ -1226,8 +1217,7 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 \
flags, const CV* cv, {
if (warn)
S_unavailable(aTHX_
- newSVpvn_flags(namepv, namelen,
- SVs_TEMP|SVf_UTF8));
+ *out_name);
*out_capture = NULL;
}
@@ -1274,8 +1264,7 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 \
flags, const CV* cv, && !PadnameIsSTATE(name_p[offset]))
{
S_unavailable(aTHX_
- newSVpvn_flags(namepv, namelen,
- SVs_TEMP|SVf_UTF8));
+ name_p[offset]);
*out_capture = NULL;
}
}
@@ -1324,7 +1313,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);
@@ -1338,7 +1327,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,
@@ -1476,7 +1464,7 @@ statements.
U32
Perl_intro_my(pTHX)
{
- SV **svp;
+ PADNAME **svp;
I32 i;
U32 seq;
@@ -1492,16 +1480,16 @@ Perl_intro_my(pTHX)
svp = PadnamelistARRAY(PL_comppad_name);
for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
- SV * const sv = svp[i];
+ PADNAME * const sv = svp[i];
- if (sv && PadnameLEN(sv) && !SvFAKE(sv)
+ if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
&& COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
{
COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad intromy: %ld \"%s\", (%lu,%lu)\n",
- (long)i, SvPVX_const(sv),
+ (long)i, PadnamePV(sv),
(unsigned long)COP_SEQ_RANGE_LOW(sv),
(unsigned long)COP_SEQ_RANGE_HIGH(sv))
);
@@ -1537,24 +1525,24 @@ Perl_pad_leavemy(pTHX)
ASSERT_CURPAD_ACTIVE("pad_leavemy");
if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
- const SV * const sv = svp[off];
- if (sv && PadnameLEN(sv) && !SvFAKE(sv))
+ const PADNAME * const name = svp[off];
+ if (name && PadnameLEN(name) && !PadnameOUTER(name))
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
- "%"SVf" never introduced",
- SVfARG(sv));
+ "%"PNf" never introduced",
+ PNfARG(name));
}
}
/* "Deintroduce" my variables that are leaving with this scope. */
for (off = PadnamelistMAX(PL_comppad_name);
off > PL_comppad_name_fill; off--) {
- SV * const sv = svp[off];
- if (sv && PadnameLEN(sv) && !SvFAKE(sv)
+ PADNAME * const sv = svp[off];
+ if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
&& COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
{
COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
- (long)off, SvPVX_const(sv),
+ (long)off, PadnamePV(sv),
(unsigned long)COP_SEQ_RANGE_LOW(sv),
(unsigned long)COP_SEQ_RANGE_HIGH(sv))
);
@@ -1615,7 +1603,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
@@ -1726,8 +1714,8 @@ Perl_pad_tidy(pTHX_ padtidy_type type)
PADOFFSET ix;
for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
- SV *namesv;
- if (!namep[ix]) namep[ix] = &PL_sv_undef;
+ PADNAME *namesv;
+ if (!namep[ix]) namep[ix] = &PL_padname_undef;
/*
* The only things that a clonable function needs in its
@@ -1738,7 +1726,7 @@ Perl_pad_tidy(pTHX_ padtidy_type type)
continue;
namesv = namep[ix];
if (!(PadnamePV(namesv) &&
- (!PadnameLEN(namesv) || *SvPVX_const(namesv) == '&')))
+ (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&')))
{
SvREFCNT_dec(PL_curpad[ix]);
PL_curpad[ix] = NULL;
@@ -1756,10 +1744,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.
@@ -1835,7 +1823,7 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST \
*padlist, int full) {
const PADNAMELIST *pad_name;
const AV *pad;
- SV **pname;
+ PADNAME **pname;
SV **ppad;
I32 ix;
@@ -1854,18 +1842,18 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST \
*padlist, int full) );
for (ix = 1; ix <= PadnamelistMAX(pad_name); ix++) {
- const SV *namesv = pname[ix];
+ const PADNAME *namesv = pname[ix];
if (namesv && !PadnameLEN(namesv)) {
namesv = NULL;
}
if (namesv) {
- if (SvFAKE(namesv))
+ if (PadnameOUTER(namesv))
Perl_dump_indent(aTHX_ level+1, file,
"%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
(int) ix,
PTR2UV(ppad[ix]),
(unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
- SvPVX_const(namesv),
+ PadnamePV(namesv),
(unsigned long)PARENT_FAKELEX_FLAGS(namesv),
(unsigned long)PARENT_PAD_INDEX(namesv)
@@ -1878,7 +1866,7 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST \
*padlist, int full) (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
(unsigned long)COP_SEQ_RANGE_LOW(namesv),
(unsigned long)COP_SEQ_RANGE_HIGH(namesv),
- SvPVX_const(namesv)
+ PadnamePV(namesv)
);
}
else if (full) {
@@ -1954,7 +1942,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool \
newcv) PADLIST* const protopadlist = CvPADLIST(proto);
PADNAMELIST *const protopad_name = PadlistNAMES(protopadlist);
const PAD *const protopad = PadlistARRAY(protopadlist)[1];
- SV** const pname = PadnamelistARRAY(protopad_name);
+ PADNAME** const pname = PadnamelistARRAY(protopad_name);
SV** const ppad = AvARRAY(protopad);
const I32 fname = PadnamelistMAX(protopad_name);
const I32 fpad = AvFILLp(protopad);
@@ -2017,14 +2005,14 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool \
newcv) CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside));
for (ix = fpad; ix > 0; ix--) {
- SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
+ PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL;
SV *sv = NULL;
if (namesv && PadnameLEN(namesv)) { /* lexical */
if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
NOOP;
}
else {
- if (SvFAKE(namesv)) { /* lexical from outside? */
+ if (PadnameOUTER(namesv)) { /* lexical from outside? */
/* formats may have an inactive, or even undefined, parent;
but state vars are always available. */
if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
@@ -2037,7 +2025,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool \
newcv) SvREFCNT_inc_simple_void_NN(sv);
}
if (!sv) {
- const char sigil = SvPVX_const(namesv)[0];
+ const char sigil = PadnamePV(namesv)[0];
if (sigil == '&')
/* If there are state subs, we need to clone them, too.
But they may need to close over variables we have
@@ -2059,14 +2047,13 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool \
newcv) upgrade to the real thing on scope entry. */
dVAR;
U32 hash;
- PERL_HASH(hash, SvPVX_const(namesv)+1,
- SvCUR(namesv) - 1);
+ PERL_HASH(hash, PadnamePV(namesv)+1,
+ PadnameLEN(namesv) - 1);
sv = newSV_type(SVt_PVCV);
CvNAME_HEK_set(
sv,
- share_hek(SvPVX_const(namesv)+1,
- (SvCUR(namesv) - 1)
- * (SvUTF8(namesv) ? -1 : 1),
+ share_hek(PadnamePV(namesv)+1,
+ 1 - PadnameLEN(namesv),
hash)
);
CvLEXICAL_on(sv);
@@ -2096,9 +2083,9 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool \
newcv)
if (subclones)
for (ix = fpad; ix > 0; ix--) {
- SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
- if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
- && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
+ PADNAME * const name = (ix <= fname) ? pname[ix] : NULL;
+ if (name && name != &PL_padname_undef && !PadnameOUTER(name)
+ && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name))
S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
}
@@ -2323,23 +2310,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);
@@ -2384,14 +2373,14 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
SV** const oldpad = AvARRAY(svp[depth-1]);
I32 ix = AvFILLp((const AV *)svp[1]);
const I32 names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]);
- SV** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]);
+ PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]);
AV *av;
for ( ;ix > 0; ix--) {
if (names_fill >= ix && PadnameLEN(names[ix])) {
- const char sigil = SvPVX_const(names[ix])[0];
- if ((SvFLAGS(names[ix]) & SVf_FAKE)
- || (SvFLAGS(names[ix]) & SVpad_STATE)
+ const char sigil = PadnamePV(names[ix])[0];
+ if (PadnameOUTER(names[ix])
+ || PadnameIsSTATE(names[ix])
|| sigil == '&')
{
/* outer lexical or anon code */
@@ -2473,7 +2462,7 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
const I32 names_fill = PadnamelistMAX(PadlistNAMES(srcpad));
const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
SV **oldpad = AvARRAY(srcpad1);
- SV ** const names = PadnamelistARRAY(PadlistNAMES(dstpad));
+ PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad));
SV **pad1a;
AV *args;
@@ -2491,9 +2480,9 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
pad1a[ix] = NULL;
} else if (names_fill >= ix && names[ix] &&
PadnameLEN(names[ix])) {
- const char sigil = SvPVX_const(names[ix])[0];
- if ((SvFLAGS(names[ix]) & SVf_FAKE)
- || (SvFLAGS(names[ix]) & SVpad_STATE)
+ const char sigil = PadnamePV(names[ix])[0];
+ if (PadnameOUTER(names[ix])
+ || PadnameIsSTATE(names[ix])
|| sigil == '&')
{
/* outer lexical or anon code */
@@ -2621,7 +2610,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];
}
@@ -2649,7 +2639,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);
}
@@ -2685,14 +2680,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:
diff --git a/pad.h b/pad.h
index c359072..3954bec 100644
--- a/pad.h
+++ b/pad.h
@@ -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 */
@@ -216,7 +186,7 @@ The index of the last pad name.
=for apidoc Amx|SSize_t|PadnamelistREFCNT|PADNAMELIST pnl
The reference count of the pad name list.
-=for apidoc Amx|SSize_t|PadnamelistREFCNT_dec|PADNAMELIST pnl
+=for apidoc Amx|void|PadnamelistREFCNT_dec|PADNAMELIST pnl
Lowers the reference count of the pad name list.
=for apidoc Amx|SV **|PadARRAY|PAD pad
@@ -226,8 +196,8 @@ The C array of pad entries.
The index of the last pad entry.
=for apidoc Amx|char *|PadnamePV|PADNAME pn
-The name stored in the pad name struct. This returns NULL for a target or
-GV slot.
+The name stored in the pad name struct. This returns NULL for a target
+slot.
=for apidoc Amx|STRLEN|PadnameLEN|PADNAME pn
The length of the name.
@@ -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. This is currently just C<pn>.
=for apidoc m|bool|PadnameIsOUR|PADNAME pn
Whether this is an "our" variable.
@@ -246,7 +215,8 @@ Whether this is an "our" variable.
The stash in which this "our" variable was declared.
=for apidoc m|bool|PadnameOUTER|PADNAME pn
-Whether this entry belongs to an outer pad.
+Whether this entry belongs to an outer pad. Entries for which this is true
+are often referred to as 'fake'.
=for apidoc m|bool|PadnameIsSTATE|PADNAME pn
Whether this is a "state" variable.
@@ -255,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>
@@ -312,19 +288,43 @@ 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)
+
+/* 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) NOOP
+#define SvPAD_OUR_on(pn) NOOP
+#define SvOURSTASH PadnameOURSTASH
+#define SvOURSTASH_set PadnameOURSTASH_set
+#define SvTYPESTASH PadnameTYPE
+#define SvTYPESTASH_set PadnameTYPE_set
+#define SVpad_STATE PADNAMEt_STATE
+
+#define PADNAMEt_OUTER 1 /* outer lexical var */
+#define PADNAMEt_STATE 2 /* state var */
+#define PADNAMEt_LVALUE 4 /* used as lvalue */
#ifdef DEBUGGING
# define PAD_SV(po) pad_sv(po)
@@ -422,7 +422,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))
@@ -432,10 +432,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))
/*
diff --git a/perl.h b/perl.h
index 52f28b1..4e2cb6d 100644
--- a/perl.h
+++ b/perl.h
@@ -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,6 +3407,9 @@ typedef pthread_key_t perl_key;
#endif
#define UTF8fARG(u,l,p) (int)cBOOL(u), (UV)(l), (void*)(p)
+#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 */
# undef UVf
diff --git a/pod/perlguts.pod b/pod/perlguts.pod
index 60f74c1..2b589fb 100644
--- a/pod/perlguts.pod
+++ b/pod/perlguts.pod
@@ -1168,7 +1168,6 @@ will be lost.
# PERL_MAGIC_arylen vtbl_arylen Array length ($#ary)
% PERL_MAGIC_rhash (none) Extra data for restricted
hashes
- & PERL_MAGIC_proto (none) my sub prototype CV
* PERL_MAGIC_debugvar vtbl_debugvar $DB::single, signal, trace
vars
. PERL_MAGIC_pos vtbl_pos pos() lvalue
diff --git a/pp.c b/pp.c
index e39d66d..43d1267 100644
--- a/pp.c
+++ b/pp.c
@@ -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;
diff --git a/proto.h b/proto.h
index 56a4394..fb1e1dd 100644
--- a/proto.h
+++ b/proto.h
@@ -2980,6 +2980,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__;
@@ -3348,6 +3362,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);
@@ -8034,6 +8053,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)
diff --git a/regen/mg_vtable.pl b/regen/mg_vtable.pl
index 7eda5e1..46dce97 100644
--- a/regen/mg_vtable.pl
+++ b/regen/mg_vtable.pl
@@ -94,7 +94,6 @@ my %mg =
desc => "Shadow \"foreach\" iterator variable /\nsmart parameter vivification" \
}, arylen => { char => '#', vtable => 'arylen', value_magic => 1,
desc => 'Array length ($#ary)' },
- proto => { char => '&', desc => 'my sub prototype CV' },
pos => { char => '.', vtable => 'pos', value_magic => 1,
desc => 'pos() lvalue' },
backref => { char => '<', vtable => 'backref', value_magic => 1,
diff --git a/scope.c b/scope.c
index 8e13071..8ffa4fb 100644
--- a/scope.c
+++ b/scope.c
@@ -969,6 +969,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;
diff --git a/scope.h b/scope.h
index cad02cd..c6a44ba 100644
--- a/scope.h
+++ b/scope.h
@@ -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))
diff --git a/sv.c b/sv.c
index 70124f7..d341e82 100644
--- a/sv.c
+++ b/sv.c
@@ -610,8 +610,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);
}
@@ -1304,10 +1302,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))
@@ -6458,10 +6452,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 */
}
@@ -6472,16 +6466,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: */
@@ -13313,7 +13303,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;
@@ -13400,11 +13390,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 */
}
@@ -13918,6 +13906,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);
@@ -14287,6 +14280,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
@@ -14567,6 +14562,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();
@@ -15077,6 +15074,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;
}
/*
@@ -15314,14 +15313,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) {
diff --git a/sv.h b/sv.h
index 00539c7..e4a0304 100644
--- a/sv.h
+++ b/sv.h
@@ -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 */
@@ -436,22 +433,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 +467,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 +496,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 +1135,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 +1217,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 +2153,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
diff --git a/t/porting/diag.t b/t/porting/diag.t
index a2ef15c..0bbc21b 100644
--- a/t/porting/diag.t
+++ b/t/porting/diag.t
@@ -175,7 +175,8 @@ my %specialformats = (IVdf => 'd',
UTF8f=> 's',
SVf256=>'s',
SVf32=> 's',
- SVf => 's');
+ SVf => 's',
+ PNf => 's');
my $format_modifiers = qr/ [#0\ +-]* # optional flags
(?: [1-9][0-9]* | \* )? # optional field width
(?: \. \d* )? # optional precision
--
Perl5 Master Repository
[prev in list] [next in list] [prev in thread] [next in thread]
Configure |
About |
News |
Add a list |
Sponsored by KoreLogic