2. regular body arenas
3. arenas for reduced-size bodies
4. Hash-Entry arenas
- 5. pte arenas (thread related)
Arena types 2 & 3 are chained by body-type off an array of
arena-root pointers, which is indexed by svtype. Some of the
HE, HEK arenas are managed separately, with separate code, but may
be merge-able later..
-
- PTE arenas are not sv-bodies, but they share these mid-level
- mechanics, so are considered here. The new mid-level mechanics rely
- on the sv_type of the body being allocated, so we just reserve one
- of the unused body-slots for PTEs, then use it in those (2) PTE
- contexts below (line ~10k)
*/
/* get_arena(size): this creates custom-sized arenas
bodies_by_type[SVt_NULL] slot is not used, as the table is not
available in hv.c.
-PTEs also use arenas, but are never seen in Perl_sv_upgrade. Nonetheless,
-they get their own slot in bodies_by_type[PTE_SVSLOT =SVt_IV], so they can
-just use the same allocation semantics. At first, PTEs were also
-overloaded to a non-body sv-type, but this yielded hard-to-find malloc
-bugs, so was simplified by claiming a new slot. This choice has no
-consequence at this time.
-
*/
struct body_details {
implemented. */
{ 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
- /* IVs are in the head, so the allocation size is 0.
- However, the slot is overloaded for PTEs. */
- { sizeof(struct ptr_tbl_ent), /* This is used for PTEs. */
+ /* IVs are in the head, so the allocation size is 0. */
+ { 0,
sizeof(IV), /* This is used to copy out the IV body. */
STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
- NOARENA /* IVS don't need an arena */,
- /* But PTEs need to know the size of their arena */
- FIT_ARENA(0, sizeof(struct ptr_tbl_ent))
+ NOARENA /* IVS don't need an arena */, 0
},
/* 8 bytes on most ILP32 with IEEE doubles */
- { sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA,
- FIT_ARENA(0, sizeof(NV)) },
+ { sizeof(NV), sizeof(NV),
+ STRUCT_OFFSET(XPVNV, xnv_u),
+ SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
/* 8 bytes on most ILP32 with IEEE doubles */
- { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
+ { sizeof(XPV),
copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
+ STRUCT_OFFSET(XPV, xpv_cur),
SVt_PV, FALSE, NONV, HASARENA,
FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
+#if 2 *PTRSIZE <= IVSIZE
/* 12 */
- { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
+ { sizeof(XPVIV),
copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
- + STRUCT_OFFSET(XPVIV, xpv_cur),
+ + STRUCT_OFFSET(XPV, xpv_cur),
SVt_PVIV, FALSE, NONV, HASARENA,
- FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
+ FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
+ /* 12 */
+#else
+ { sizeof(XPVIV),
+ copy_length(XPVIV, xiv_u),
+ 0,
+ SVt_PVIV, FALSE, NONV, HASARENA,
+ FIT_ARENA(0, sizeof(XPVIV)) },
+#endif
+#if (2 *PTRSIZE <= IVSIZE) && (2 *PTRSIZE <= NVSIZE)
+ /* 20 */
+ { sizeof(XPVNV),
+ copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
+ + STRUCT_OFFSET(XPV, xpv_cur),
+ SVt_PVNV, FALSE, HADNV, HASARENA,
+ FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
+#else
/* 20 */
- { sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, SVt_PVNV, FALSE, HADNV,
+ { sizeof(XPVNV), copy_length(XPVNV, xnv_u), 0, SVt_PVNV, FALSE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVNV)) },
+#endif
/* 28 */
- { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
+ { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
/* something big */
- { sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur),
- sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur),
- + STRUCT_OFFSET(regexp, xpv_cur),
+ { sizeof(regexp),
+ sizeof(regexp),
+ 0,
SVt_REGEXP, FALSE, NONV, HASARENA,
FIT_ARENA(0, sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur))
},
{ sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
- { sizeof(XPVAV) - STRUCT_OFFSET(XPVAV, xav_fill),
- copy_length(XPVAV, xmg_stash) - STRUCT_OFFSET(XPVAV, xav_fill),
- + STRUCT_OFFSET(XPVAV, xav_fill),
+ { sizeof(XPVAV),
+ copy_length(XPVAV, xav_alloc),
+ 0,
SVt_PVAV, TRUE, NONV, HASARENA,
- FIT_ARENA(0, sizeof(XPVAV) - STRUCT_OFFSET(XPVAV, xav_fill)) },
+ FIT_ARENA(0, sizeof(XPVAV)) },
- { sizeof(XPVHV) - STRUCT_OFFSET(XPVHV, xhv_fill),
- copy_length(XPVHV, xmg_stash) - STRUCT_OFFSET(XPVHV, xhv_fill),
- + STRUCT_OFFSET(XPVHV, xhv_fill),
+ { sizeof(XPVHV),
+ copy_length(XPVHV, xhv_max),
+ 0,
SVt_PVHV, TRUE, NONV, HASARENA,
- FIT_ARENA(0, sizeof(XPVHV) - STRUCT_OFFSET(XPVHV, xhv_fill)) },
+ FIT_ARENA(0, sizeof(XPVHV)) },
/* 56 */
- { sizeof(XPVCV) - STRUCT_OFFSET(XPVCV, xpv_cur),
- sizeof(XPVCV) - STRUCT_OFFSET(XPVCV, xpv_cur),
- + STRUCT_OFFSET(XPVCV, xpv_cur),
+ { sizeof(XPVCV),
+ sizeof(XPVCV),
+ 0,
SVt_PVCV, TRUE, NONV, HASARENA,
- FIT_ARENA(0, sizeof(XPVCV) - STRUCT_OFFSET(XPVCV, xpv_cur)) },
+ FIT_ARENA(0, sizeof(XPVCV)) },
- { sizeof(XPVFM) - STRUCT_OFFSET(XPVFM, xpv_cur),
- sizeof(XPVFM) - STRUCT_OFFSET(XPVFM, xpv_cur),
- + STRUCT_OFFSET(XPVFM, xpv_cur),
+ { sizeof(XPVFM),
+ sizeof(XPVFM),
+ 0,
SVt_PVFM, TRUE, NONV, NOARENA,
- FIT_ARENA(20, sizeof(XPVFM) - STRUCT_OFFSET(XPVFM, xpv_cur)) },
+ FIT_ARENA(20, sizeof(XPVFM)) },
/* XPVIO is 84 bytes, fits 48x */
- { sizeof(XPVIO) - STRUCT_OFFSET(XPVIO, xpv_cur),
- sizeof(XPVIO) - STRUCT_OFFSET(XPVIO, xpv_cur),
- + STRUCT_OFFSET(XPVIO, xpv_cur),
+ { sizeof(XPVIO),
+ sizeof(XPVIO),
+ 0,
SVt_PVIO, TRUE, NONV, HASARENA,
- FIT_ARENA(24, sizeof(XPVIO) - STRUCT_OFFSET(XPVIO, xpv_cur)) },
+ FIT_ARENA(24, sizeof(XPVIO)) },
};
-#define new_body_type(sv_type) \
- (void *)((char *)S_new_body(aTHX_ sv_type))
-
-#define del_body_type(p, sv_type) \
- del_body(p, &PL_body_roots[sv_type])
-
-
#define new_body_allocated(sv_type) \
(void *)((char *)S_new_body(aTHX_ sv_type) \
- bodies_by_type[sv_type].offset)
#else /* !PURIFY */
-#define new_XNV() new_body_type(SVt_NV)
-#define del_XNV(p) del_body_type(p, SVt_NV)
+#define new_XNV() new_body_allocated(SVt_NV)
+#define del_XNV(p) del_body_allocated(p, SVt_NV)
-#define new_XPVNV() new_body_type(SVt_PVNV)
-#define del_XPVNV(p) del_body_type(p, SVt_PVNV)
+#define new_XPVNV() new_body_allocated(SVt_PVNV)
+#define del_XPVNV(p) del_body_allocated(p, SVt_PVNV)
#define new_XPVAV() new_body_allocated(SVt_PVAV)
#define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
#define new_XPVHV() new_body_allocated(SVt_PVHV)
#define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
-#define new_XPVMG() new_body_type(SVt_PVMG)
-#define del_XPVMG(p) del_body_type(p, SVt_PVMG)
+#define new_XPVMG() new_body_allocated(SVt_PVMG)
+#define del_XPVMG(p) del_body_allocated(p, SVt_PVMG)
-#define new_XPVGV() new_body_type(SVt_PVGV)
-#define del_XPVGV(p) del_body_type(p, SVt_PVGV)
+#define new_XPVGV() new_body_allocated(SVt_PVGV)
+#define del_XPVGV(p) del_body_allocated(p, SVt_PVGV)
#endif /* PURIFY */
HvSHAREKEYS_on(sv); /* key-sharing on by default */
#endif
HvMAX(sv) = 7; /* (start with 8 buckets) */
- if (old_type_details->body_size) {
- HvFILL(sv) = 0;
- } else {
- /* It will have been zeroed when the new body was allocated.
- Lets not write to it, in case it confuses a write-back
- cache. */
- }
}
/* SVt_NULL isn't the only thing upgraded to AV or HV.
(unsigned long)new_type);
}
- if (old_type > SVt_IV) { /* SVt_IVs are overloaded for PTEs */
+ if (old_type > SVt_IV) {
#ifdef PURIFY
my_safefree(old_body);
#else
case SVt_PVFM:
case SVt_PVIO:
Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
- OP_NAME(PL_op));
+ OP_DESC(PL_op));
default: NOOP;
}
SvNV_set(sv, num);
if (SvROK(sv)) {
return_rok:
if (SvAMAGIC(sv)) {
- SV * const tmpstr=AMG_CALLun(sv,numer);
+ SV * tmpstr;
+ if (flags & SV_SKIP_OVERLOAD)
+ return 0;
+ tmpstr=AMG_CALLun(sv,numer);
if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
return SvIV(tmpstr);
}
if (SvROK(sv)) {
return_rok:
if (SvAMAGIC(sv)) {
- SV *const tmpstr = AMG_CALLun(sv,numer);
+ SV *tmpstr;
+ if (flags & SV_SKIP_OVERLOAD)
+ return 0;
+ tmpstr = AMG_CALLun(sv,numer);
if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
return SvUV(tmpstr);
}
}
/*
-=for apidoc sv_2nv
+=for apidoc sv_2nv_flags
Return the num value of an SV, doing any necessary string or integer
-conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
-macros.
+conversion. If flags includes SV_GMAGIC, does an mg_get() first.
+Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
=cut
*/
NV
-Perl_sv_2nv(pTHX_ register SV *const sv)
+Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
{
dVAR;
if (!sv)
if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
/* FBMs use the same flag bit as SVf_IVisUV, so must let them
cache IVs just in case. */
- mg_get(sv);
+ if (flags & SV_GMAGIC)
+ mg_get(sv);
if (SvNOKp(sv))
return SvNVX(sv);
if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
if (SvROK(sv)) {
return_rok:
if (SvAMAGIC(sv)) {
- SV *const tmpstr = AMG_CALLun(sv,numer);
+ SV *tmpstr;
+ if (flags & SV_SKIP_OVERLOAD)
+ return 0;
+ tmpstr = AMG_CALLun(sv,numer);
if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
return SvNV(tmpstr);
}
return sv;
if (SvAMAGIC(sv)) {
SV * const tmpsv = AMG_CALLun(sv,numer);
+ TAINT_IF(tmpsv && SvTAINTED(tmpsv));
if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
return sv_2num(tmpsv);
}
if (SvROK(sv)) {
return_rok:
if (SvAMAGIC(sv)) {
- SV *const tmpstr = AMG_CALLun(sv,string);
+ SV *tmpstr;
+ if (flags & SV_SKIP_OVERLOAD)
+ return NULL;
+ tmpstr = AMG_CALLun(sv,string);
+ TAINT_IF(tmpstr && SvTAINTED(tmpstr));
if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
/* Unwrap this: */
/* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
if (SvAMAGIC(sv)) {
SV * const tmpsv = AMG_CALLun(sv,bool_);
if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
- return (bool)SvTRUE(tmpsv);
+ return cBOOL(SvTRUE(tmpsv));
}
return SvRV(sv) != 0;
}
sv_force_normal_flags(sv, 0);
}
if (SvREADONLY(sv)) {
- Perl_croak(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
}
(void) sv_utf8_upgrade(sv);
SvUTF8_off(sv);
SV **location;
U8 import_flag = 0;
const U32 stype = SvTYPE(sref);
- bool mro_changes = FALSE;
PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
goto common;
case SVt_PVAV:
location = (SV **) &GvAV(dstr);
- if (strEQ(GvNAME((GV*)dstr), "ISA"))
- mro_changes = TRUE;
import_flag = GVf_IMPORTED_AV;
goto common;
case SVt_PVIO:
&& CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
GvFLAGS(dstr) |= import_flag;
}
+ if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) {
+ sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
+ mro_isa_changed_in(GvSTASH(dstr));
+ }
break;
}
SvREFCNT_dec(dref);
if (SvTAINTED(sstr))
SvTAINT(dstr);
- if (mro_changes) mro_isa_changed_in(GvSTASH(dstr));
return;
}
{
const char * const type = sv_reftype(sstr,0);
if (PL_op)
- Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
+ Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
else
Perl_croak(aTHX_ "Bizarre copy of %s", type);
}
} else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
const char * const type = sv_reftype(dstr,0);
if (PL_op)
- Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_NAME(PL_op));
+ Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
else
Perl_croak(aTHX_ "Cannot copy to %s", type);
} else if (sflags & SVf_ROK) {
(!(flags & SV_NOSTEAL)) &&
/* and we're allowed to steal temps */
SvREFCNT(sstr) == 1 && /* and no other references to it? */
- SvLEN(sstr) && /* and really is a string */
- /* and won't be needed again, potentially */
- !(PL_op && PL_op->op_type == OP_AASSIGN))
+ SvLEN(sstr)) /* and really is a string */
#ifdef PERL_OLD_COPY_ON_WRITE
&& ((flags & SV_COW_SHARED_HASH_KEYS)
? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
}
}
else if (IN_PERL_RUNTIME)
- Perl_croak(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
}
#else
if (SvREADONLY(sv)) {
unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
}
else if (IN_PERL_RUNTIME)
- Perl_croak(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
}
#endif
if (SvROK(sv))
&& how != PERL_MAGIC_backref
)
{
- Perl_croak(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
}
}
if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
/* A discussion about the backreferences array and its refcount:
*
* The AV holding the backreferences is pointed to either as the mg_obj of
- * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
- * structure, from the xhv_backreferences field. (A HV without hv_aux will
- * have the standard magic instead.) The array is created with a refcount
- * of 2. This means that if during global destruction the array gets
- * picked on first to have its refcount decremented by the random zapper,
- * it won't actually be freed, meaning it's still theere for when its
- * parent gets freed.
+ * PERL_MAGIC_backref, or in the specific case of a HV, from the
+ * xhv_backreferences field of the HvAUX structure. The array is created
+ * with a refcount of 2. This means that if during global destruction the
+ * array gets picked on before its parent to have its refcount decremented
+ * by the random zapper, it won't actually be freed, meaning it's still
+ * there for when its parent gets freed.
* When the parent SV is freed, in the case of magic, the magic is freed,
* Perl_magic_killbackrefs is called which decrements one refcount, then
* mg_obj is freed which kills the second count.
- * In the vase of a HV being freed, one ref is removed by
- * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it
- * calls.
+ * In the vase of a HV being freed, one ref is removed by S_hfreeentries,
+ * the other by Perl_sv_kill_backrefs, which it calls.
*/
void
av = *avp;
if (!av) {
- /* There is no AV in the offical place - try a fixup. */
- MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
-
- if (mg) {
- /* Aha. They've got it stowed in magic. Bring it back. */
- av = MUTABLE_AV(mg->mg_obj);
- /* Stop mg_free decreasing the refernce count. */
- mg->mg_obj = NULL;
- /* Stop mg_free even calling the destructor, given that
- there's no AV to free up. */
- mg->mg_virtual = 0;
- sv_unmagic(tsv, PERL_MAGIC_backref);
- } else {
- av = newAV();
- AvREAL_off(av);
- SvREFCNT_inc_simple_void(av); /* see discussion above */
- }
+ av = newAV();
+ AvREAL_off(av);
+ SvREFCNT_inc_simple_void(av); /* see discussion above */
*avp = av;
}
} else {
* with the SV we point to.
*/
-STATIC void
-S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
+void
+Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
{
dVAR;
AV *av = NULL;
SV **svp = AvARRAY(av);
PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
- PERL_UNUSED_ARG(sv);
- assert(!svp || !SvIS_FREED(av));
if (svp) {
SV *const *const last = svp + AvFILLp(av);
+ assert(!SvIS_FREED(av));
while (svp <= last) {
if (*svp) {
SV *const referrer = *svp;
if (SvWEAKREF(referrer)) {
/* XXX Should we check that it hasn't changed? */
+ assert(SvROK(referrer));
SvRV_set(referrer, 0);
SvOK_off(referrer);
SvWEAKREF_off(referrer);
SvSETMAGIC(referrer);
} else if (SvTYPE(referrer) == SVt_PVGV ||
SvTYPE(referrer) == SVt_PVLV) {
+ assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
/* You lookin' at me? */
assert(GvSTASH(referrer));
assert(GvSTASH(referrer) == (const HV *)sv);
GvSTASH(referrer) = 0;
+ } else if (SvTYPE(referrer) == SVt_PVCV ||
+ SvTYPE(referrer) == SVt_PVFM) {
+ if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
+ /* You lookin' at me? */
+ assert(CvSTASH(referrer));
+ assert(CvSTASH(referrer) == (const HV *)sv);
+ CvSTASH(referrer) = 0;
+ }
+ else {
+ assert(SvTYPE(sv) == SVt_PVGV);
+ /* You lookin' at me? */
+ assert(CvGV(referrer));
+ assert(CvGV(referrer) == (const GV *)sv);
+ anonymise_cv_maybe(MUTABLE_GV(sv),
+ MUTABLE_CV(referrer));
+ }
+
} else {
Perl_croak(aTHX_
"panic: magic_killbackrefs (flags=%"UVxf")",
}
svp++;
}
+ AvFILLp(av) = -1;
}
SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
return 0;
del_SV(nsv);
}
+/* We're about to free a GV which has a CV that refers back to us.
+ * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
+ * field) */
+
+STATIC void
+S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
+{
+ char *stash;
+ SV *gvname;
+ GV *anongv;
+
+ PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
+
+ /* be assertive! */
+ assert(SvREFCNT(gv) == 0);
+ assert(isGV(gv) && isGV_with_GP(gv));
+ assert(GvGP(gv));
+ assert(!CvANON(cv));
+ assert(CvGV(cv) == gv);
+
+ /* will the CV shortly be freed by gp_free() ? */
+ if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
+ SvANY(cv)->xcv_gv = NULL;
+ return;
+ }
+
+ /* if not, anonymise: */
+ stash = GvSTASH(gv) ? HvNAME(GvSTASH(gv)) : NULL;
+ gvname = Perl_newSVpvf(aTHX_ "%s::__ANON__",
+ stash ? stash : "__ANON__");
+ anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
+ SvREFCNT_dec(gvname);
+
+ CvANON_on(cv);
+ CvCVGV_RC_on(cv);
+ SvANY(cv)->xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
+}
+
+
/*
=for apidoc sv_clear
if (type <= SVt_IV) {
/* See the comment in sv.h about the collusion between this early
- return and the overloading of the NULL and IV slots in the size
- table. */
- if (SvROK(sv)) {
- SV * const target = SvRV(sv);
- if (SvWEAKREF(sv))
- sv_del_backref(target, sv);
- else
- SvREFCNT_dec(target);
- }
+ return and the overloading of the NULL slots in the size table. */
+ if (SvROK(sv))
+ goto free_rv;
SvFLAGS(sv) &= SVf_BREAK;
SvFLAGS(sv) |= SVTYPEMASK;
return;
if (IoIFP(sv) &&
IoIFP(sv) != PerlIO_stdin() &&
IoIFP(sv) != PerlIO_stdout() &&
- IoIFP(sv) != PerlIO_stderr())
+ IoIFP(sv) != PerlIO_stderr() &&
+ !(IoFLAGS(sv) & IOf_FAKE_DIRP))
{
io_close(MUTABLE_IO(sv), FALSE);
}
case SVt_PVCV:
case SVt_PVFM:
cv_undef(MUTABLE_CV(sv));
+ /* If we're in a stash, we don't own a reference to it. However it does
+ have a back reference to us, which needs to be cleared. */
+ if ((stash = CvSTASH(sv)))
+ sv_del_backref(MUTABLE_SV(stash), sv);
goto freescalar;
case SVt_PVHV:
if (PL_last_swash_hv == (const HV *)sv) {
PL_last_swash_hv = NULL;
}
- Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
hv_undef(MUTABLE_HV(sv));
break;
case SVt_PVAV:
/* Don't even bother with turning off the OOK flag. */
}
if (SvROK(sv)) {
- SV * const target = SvRV(sv);
- if (SvWEAKREF(sv))
- sv_del_backref(target, sv);
- else
- SvREFCNT_dec(target);
+ free_rv:
+ {
+ SV * const target = SvRV(sv);
+ if (SvWEAKREF(sv))
+ sv_del_backref(target, sv);
+ else
+ SvREFCNT_dec(target);
+ }
}
#ifdef PERL_OLD_COPY_ON_WRITE
- else if (SvPVX_const(sv)) {
+ else if (SvPVX_const(sv)
+ && !(SvTYPE(sv) == SVt_PVIO && !(IoFLAGS(sv) & IOf_FAKE_DIRP))) {
if (SvIsCOW(sv)) {
if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
}
}
#else
- else if (SvPVX_const(sv) && SvLEN(sv))
+ else if (SvPVX_const(sv) && SvLEN(sv)
+ && !(SvTYPE(sv) == SVt_PVIO && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
Safefree(SvPVX_mutable(sv));
else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
STRLEN ulen;
MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
- if (mg && mg->mg_len != -1) {
- ulen = mg->mg_len;
+ if (mg && (mg->mg_len != -1 || mg->mg_ptr)) {
+ if (mg->mg_len != -1)
+ ulen = mg->mg_len;
+ else {
+ /* We can use the offset cache for a headstart.
+ The longer value is stored in the first pair. */
+ STRLEN *cache = (STRLEN *) mg->mg_ptr;
+
+ ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1],
+ s + len);
+ }
+
if (PL_utf8cache < 0) {
const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
- if (real != ulen) {
- /* Need to turn the assertions off otherwise we may
- recurse infinitely while printing error messages.
- */
- SAVEI8(PL_utf8cache);
- PL_utf8cache = 0;
- Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf
- " real %"UVuf" for %"SVf,
- (UV) ulen, (UV) real, SVfARG(sv));
- }
+ assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv);
}
}
else {
ulen = Perl_utf8_length(aTHX_ s, s + len);
- if (!SvREADONLY(sv)) {
- if (!mg && (SvTYPE(sv) < SVt_PVMG ||
- !(mg = mg_find(sv, PERL_MAGIC_utf8)))) {
- mg = sv_magicext(sv, 0, PERL_MAGIC_utf8,
- &PL_vtbl_utf8, 0, 0);
- }
- assert(mg);
- mg->mg_len = ulen;
- }
+ utf8_mg_len_cache_update(sv, &mg, ulen);
}
return ulen;
}
offset. */
static STRLEN
S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
- STRLEN uoffset)
+ STRLEN *const uoffset_p, bool *const at_end)
{
const U8 *s = start;
+ STRLEN uoffset = *uoffset_p;
PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
- while (s < send && uoffset--)
+ while (s < send && uoffset) {
+ --uoffset;
s += UTF8SKIP(s);
- if (s > send) {
+ }
+ if (s == send) {
+ *at_end = TRUE;
+ }
+ else if (s > send) {
+ *at_end = TRUE;
/* This is the existing behaviour. Possibly it should be a croak, as
it's actually a bounds error */
s = send;
}
+ *uoffset_p -= uoffset;
return s - start;
}
the passed in UTF-8 offset. */
static STRLEN
S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
- const STRLEN uoffset, const STRLEN uend)
+ STRLEN uoffset, const STRLEN uend)
{
STRLEN backw = uend - uoffset;
/* The assumption is that going forwards is twice the speed of going
forward (that's where the 2 * backw comes from).
(The real figure of course depends on the UTF-8 data.) */
- return sv_pos_u2b_forwards(start, send, uoffset);
+ const U8 *s = start;
+
+ while (s < send && uoffset--)
+ s += UTF8SKIP(s);
+ assert (s <= send);
+ if (s > send)
+ s = send;
+ return s - start;
}
while (backw--) {
created if necessary, and the found value offered to it for update. */
static STRLEN
S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
- const U8 *const send, const STRLEN uoffset,
+ const U8 *const send, STRLEN uoffset,
STRLEN uoffset0, STRLEN boffset0)
{
STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
bool found = FALSE;
+ bool at_end = FALSE;
PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
assert (uoffset >= uoffset0);
+ if (!uoffset)
+ return 0;
+
if (!SvREADONLY(sv)
&& PL_utf8cache
&& (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
uoffset - uoffset0,
(*mgp)->mg_len - uoffset0);
} else {
+ uoffset -= uoffset0;
boffset = boffset0
+ sv_pos_u2b_forwards(start + boffset0,
- send, uoffset - uoffset0);
+ send, &uoffset, &at_end);
+ uoffset += uoffset0;
}
}
else if (cache[2] < uoffset) {
}
if (!found || PL_utf8cache < 0) {
- const STRLEN real_boffset
- = boffset0 + sv_pos_u2b_forwards(start + boffset0,
- send, uoffset - uoffset0);
-
- if (found && PL_utf8cache < 0) {
- if (real_boffset != boffset) {
- /* Need to turn the assertions off otherwise we may recurse
- infinitely while printing error messages. */
- SAVEI8(PL_utf8cache);
- PL_utf8cache = 0;
- Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf
- " real %"UVuf" for %"SVf,
- (UV) boffset, (UV) real_boffset, SVfARG(sv));
- }
- }
+ STRLEN real_boffset;
+ uoffset -= uoffset0;
+ real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0,
+ send, &uoffset, &at_end);
+ uoffset += uoffset0;
+
+ if (found && PL_utf8cache < 0)
+ assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset,
+ real_boffset, sv);
boffset = real_boffset;
}
- if (PL_utf8cache)
- utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
+ if (PL_utf8cache) {
+ if (at_end)
+ utf8_mg_len_cache_update(sv, mgp, uoffset);
+ else
+ utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
+ }
return boffset;
}
/*
-=for apidoc sv_pos_u2b_proper
+=for apidoc sv_pos_u2b_flags
Converts the value pointed to by offsetp from a count of UTF-8 chars from
the start of the string, to a count of the equivalent number of bytes; if
lenp is non-zero, it does the same to lenp, but this time starting from
-the offset, rather than from the start of the string. Handles magic and
-type coercion.
+the offset, rather than from the start of the string. Handles type coercion.
+I<flags> is passed to C<SvPV_flags>, and usually should be
+C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
=cut
*/
/*
- * sv_pos_u2b_proper() uses, like sv_pos_b2u(), the mg_ptr of the potential
+ * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
* PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
* byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
*
*/
-void
-Perl_sv_pos_u2b_proper(pTHX_ register SV *const sv, STRLEN *const offsetp, STRLEN *const lenp)
+STRLEN
+Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
+ U32 flags)
{
const U8 *start;
STRLEN len;
+ STRLEN boffset;
- PERL_ARGS_ASSERT_SV_POS_U2B;
+ PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
- if (!sv)
- return;
-
- start = (U8*)SvPV_const(sv, len);
+ start = (U8*)SvPV_flags(sv, len, flags);
if (len) {
- STRLEN uoffset = *offsetp;
const U8 * const send = start + len;
MAGIC *mg = NULL;
- const STRLEN boffset = sv_pos_u2b_cached(sv, &mg, start, send,
- uoffset, 0, 0);
-
- *offsetp = boffset;
+ boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
- if (lenp) {
+ if (lenp
+ && *lenp /* don't bother doing work for 0, as its bytes equivalent
+ is 0, and *lenp is already set to that. */) {
/* Convert the relative offset to absolute. */
const STRLEN uoffset2 = uoffset + *lenp;
const STRLEN boffset2
*lenp = boffset2;
}
- }
- else {
- *offsetp = 0;
- if (lenp)
- *lenp = 0;
+ } else {
+ if (lenp)
+ *lenp = 0;
+ boffset = 0;
}
- return;
+ return boffset;
}
/*
the offset, rather than from the start of the string. Handles magic and
type coercion.
+Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
+than 2Gb.
+
=cut
*/
void
Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
{
- STRLEN uoffset = (STRLEN)*offsetp;
+ PERL_ARGS_ASSERT_SV_POS_U2B;
+
if (lenp) {
STRLEN ulen = (STRLEN)*lenp;
- sv_pos_u2b_proper(sv, &uoffset, &ulen);
+ *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
+ SV_GMAGIC|SV_CONST_RETURN);
*lenp = (I32)ulen;
} else {
- sv_pos_u2b_proper(sv, &uoffset, NULL);
+ *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
+ SV_GMAGIC|SV_CONST_RETURN);
}
- *offsetp = (I32)uoffset;
+}
+
+static void
+S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp,
+ const STRLEN ulen)
+{
+ PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
+ if (SvREADONLY(sv))
+ return;
+
+ if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
+ !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
+ *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
+ }
+ assert(*mgp);
+
+ (*mgp)->mg_len = ulen;
+ /* For now, treat "overflowed" as "still unknown". See RT #72924. */
+ if (ulen != (STRLEN) (*mgp)->mg_len)
+ (*mgp)->mg_len = -1;
}
/* Create and update the UTF8 magic offset cache, with the proffered utf8/
const U8 *start = (const U8 *) SvPVX_const(sv);
const STRLEN realutf8 = utf8_length(start, start + byte);
- if (realutf8 != utf8) {
- /* Need to turn the assertions off otherwise we may recurse
- infinitely while printing error messages. */
- SAVEI8(PL_utf8cache);
- PL_utf8cache = 0;
- Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf
- " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv));
- }
+ assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8,
+ sv);
}
/* Cache is held with the later position first, to simplify the code
if (!found || PL_utf8cache < 0) {
const STRLEN real_len = utf8_length(s, send);
- if (found && PL_utf8cache < 0) {
- if (len != real_len) {
- /* Need to turn the assertions off otherwise we may recurse
- infinitely while printing error messages. */
- SAVEI8(PL_utf8cache);
- PL_utf8cache = 0;
- Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf
- " real %"UVuf" for %"SVf,
- (UV) len, (UV) real_len, SVfARG(sv));
- }
- }
+ if (found && PL_utf8cache < 0)
+ assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv);
len = real_len;
}
*offsetp = len;
- if (PL_utf8cache)
- utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
+ if (PL_utf8cache) {
+ if (blen == byte)
+ utf8_mg_len_cache_update(sv, &mg, len);
+ else
+ utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
+ }
+}
+
+static void
+S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache,
+ STRLEN real, SV *const sv)
+{
+ PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT;
+
+ /* As this is debugging only code, save space by keeping this test here,
+ rather than inlining it in all the callers. */
+ if (from_cache == real)
+ return;
+
+ /* Need to turn the assertions off otherwise we may recurse infinitely
+ while printing error messages. */
+ SAVEI8(PL_utf8cache);
+ PL_utf8cache = 0;
+ Perl_croak(aTHX_ "panic: %s cache %"UVuf" real %"UVuf" for %"SVf,
+ func, (UV) from_cache, (UV) real, SVfARG(sv));
}
/*
}
SvPOK_only(sv);
+ if (!append) {
+ SvCUR_set(sv,0);
+ }
if (PerlIO_isutf8(fp))
SvUTF8_on(sv);
=for apidoc sv_inc
Auto-increment of the value in the SV, doing string to numeric conversion
-if necessary. Handles 'get' magic.
+if necessary. Handles 'get' magic and operator overloading.
=cut
*/
void
Perl_sv_inc(pTHX_ register SV *const sv)
{
+ if (!sv)
+ return;
+ SvGETMAGIC(sv);
+ sv_inc_nomg(sv);
+}
+
+/*
+=for apidoc sv_inc_nomg
+
+Auto-increment of the value in the SV, doing string to numeric conversion
+if necessary. Handles operator overloading. Skips handling 'get' magic.
+
+=cut
+*/
+
+void
+Perl_sv_inc_nomg(pTHX_ register SV *const sv)
+{
dVAR;
register char *d;
int flags;
if (!sv)
return;
- SvGETMAGIC(sv);
if (SvTHINKFIRST(sv)) {
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
if (IN_PERL_RUNTIME)
- Perl_croak(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
}
if (SvROK(sv)) {
IV i;
=for apidoc sv_dec
Auto-decrement of the value in the SV, doing string to numeric conversion
-if necessary. Handles 'get' magic.
+if necessary. Handles 'get' magic and operator overloading.
=cut
*/
Perl_sv_dec(pTHX_ register SV *const sv)
{
dVAR;
+ if (!sv)
+ return;
+ SvGETMAGIC(sv);
+ sv_dec_nomg(sv);
+}
+
+/*
+=for apidoc sv_dec_nomg
+
+Auto-decrement of the value in the SV, doing string to numeric conversion
+if necessary. Handles operator overloading. Skips handling 'get' magic.
+
+=cut
+*/
+
+void
+Perl_sv_dec_nomg(pTHX_ register SV *const sv)
+{
+ dVAR;
int flags;
if (!sv)
return;
- SvGETMAGIC(sv);
if (SvTHINKFIRST(sv)) {
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
if (IN_PERL_RUNTIME)
- Perl_croak(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
}
if (SvROK(sv)) {
IV i;
C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
If C<SVs_TEMP> is set, then C<sv2mortal()> is called on the result before
-returning. If C<SVf_UTF8> is set, then it will be set on the new SV.
+returning. If C<SVf_UTF8> is set, C<s> is considered to be in UTF-8 and the
+C<SVf_UTF8> flag will be set on the new SV.
C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
#define newSVpvn_utf8(s, len, u) \
const char * const ref = sv_reftype(sv,0);
if (PL_op)
Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
- ref, OP_NAME(PL_op));
+ ref, OP_DESC(PL_op));
else
Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
}
if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
|| isGV_with_GP(sv))
Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
- OP_NAME(PL_op));
+ OP_DESC(PL_op));
s = sv_2pv_flags(sv, &len, flags);
if (lp)
*lp = len;
if (SvIsCOW(tmpRef))
sv_force_normal_flags(tmpRef, 0);
if (SvREADONLY(tmpRef))
- Perl_croak(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
if (SvOBJECT(tmpRef)) {
if (SvTYPE(tmpRef) != SVt_PVIO)
--PL_sv_objcount;
while (isDIGIT(**pattern)) {
const I32 tmp = var * 10 + (*(*pattern)++ - '0');
if (tmp < var)
- Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn"));
+ Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn"));
var = tmp;
}
}
else if (svix < svmax) {
sv_catsv(sv, *svargs);
}
+ else
+ S_vcatpvfn_missing_argument(aTHX);
return;
}
if (args && patlen == 3 && pat[0] == '%' &&
pp = pat + 2;
while (*pp >= '0' && *pp <= '9')
digits = 10 * digits + (*pp++ - '0');
- if (pp - pat == (int)patlen - 1) {
- NV nv;
-
- if (svix < svmax)
- nv = SvNV(*svargs);
- else
- return;
+ if (pp - pat == (int)patlen - 1 && svix < svmax) {
+ const NV nv = SvNV(*svargs);
if (*pp == 'g') {
/* Add check for digits != 0 because it seems that some
gconverts are buggy in this case, and we don't yet have
goto vector;
}
}
+ SvTAINT(sv);
}
/* =========================================================================
that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
If this changes, please unmerge ss_dup.
Likewise, sv_dup_inc_multiple() relies on this fact. */
-#define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
-#define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t))
+#define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup_inc(s,t))
#define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t))
-#define av_dup_inc(s,t) MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
+#define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
#define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t))
-#define hv_dup_inc(s,t) MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
+#define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
#define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t))
-#define cv_dup_inc(s,t) MUTABLE_CV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
+#define cv_dup_inc(s,t) MUTABLE_CV(sv_dup_inc((const SV *)s,t))
#define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t))
-#define io_dup_inc(s,t) MUTABLE_IO(SvREFCNT_inc(sv_dup((const SV *)s,t)))
+#define io_dup_inc(s,t) MUTABLE_IO(sv_dup_inc((const SV *)s,t))
#define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t))
-#define gv_dup_inc(s,t) MUTABLE_GV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
+#define gv_dup_inc(s,t) MUTABLE_GV(sv_dup_inc((const SV *)s,t))
#define SAVEPV(p) ((p) ? savepv(p) : NULL)
#define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
for (; mg; mg = mg->mg_moremagic) {
MAGIC *nmg;
+
+ if ((param->flags & CLONEf_JOIN_IN)
+ && mg->mg_type == PERL_MAGIC_backref)
+ /* when joining, we let the individual SVs add themselves to
+ * backref as needed. */
+ continue;
+
Newx(nmg, 1, MAGIC);
*mgprev_p = nmg;
mgprev_p = &(nmg->mg_moremagic);
#endif /* USE_ITHREADS */
+struct ptr_tbl_arena {
+ struct ptr_tbl_arena *next;
+ struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers. */
+};
+
/* create a new pointer-mapping table */
PTR_TBL_t *
Newx(tbl, 1, PTR_TBL_t);
tbl->tbl_max = 511;
tbl->tbl_items = 0;
+ tbl->tbl_arena = NULL;
+ tbl->tbl_arena_next = NULL;
+ tbl->tbl_arena_end = NULL;
Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
return tbl;
}
#define PTR_TABLE_HASH(ptr) \
((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
-/*
- we use the PTE_SVSLOT 'reservation' made above, both here (in the
- following define) and at call to new_body_inline made below in
- Perl_ptr_table_store()
- */
-
-#define del_pte(p) del_body_type(p, PTE_SVSLOT)
-
/* map an existing pointer using a table */
STATIC PTR_TBL_ENT_t *
} else {
const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
- new_body_inline(tblent, PTE_SVSLOT);
+ if (tbl->tbl_arena_next == tbl->tbl_arena_end) {
+ struct ptr_tbl_arena *new_arena;
+
+ Newx(new_arena, 1, struct ptr_tbl_arena);
+ new_arena->next = tbl->tbl_arena;
+ tbl->tbl_arena = new_arena;
+ tbl->tbl_arena_next = new_arena->array;
+ tbl->tbl_arena_end = new_arena->array
+ + sizeof(new_arena->array) / sizeof(new_arena->array[0]);
+ }
+
+ tblent = tbl->tbl_arena_next++;
tblent->oldval = oldsv;
tblent->newval = newsv;
tbl->tbl_max = --newsize;
tbl->tbl_ary = ary;
for (i=0; i < oldsize; i++, ary++) {
- PTR_TBL_ENT_t **curentp, **entp, *ent;
- if (!*ary)
+ PTR_TBL_ENT_t **entp = ary;
+ PTR_TBL_ENT_t *ent = *ary;
+ PTR_TBL_ENT_t **curentp;
+ if (!ent)
continue;
curentp = ary + oldsize;
- for (entp = ary, ent = *ary; ent; ent = *entp) {
+ do {
if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
*entp = ent->next;
ent->next = *curentp;
*curentp = ent;
- continue;
}
else
entp = &ent->next;
- }
+ ent = *entp;
+ } while (ent);
}
}
/* remove all the entries from a ptr table */
+/* Deprecated - will be removed post 5.14 */
void
Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
{
if (tbl && tbl->tbl_items) {
- register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary;
- UV riter = tbl->tbl_max;
+ struct ptr_tbl_arena *arena = tbl->tbl_arena;
- do {
- PTR_TBL_ENT_t *entry = array[riter];
+ Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
- while (entry) {
- PTR_TBL_ENT_t * const oentry = entry;
- entry = entry->next;
- del_pte(oentry);
- }
- } while (riter--);
+ while (arena) {
+ struct ptr_tbl_arena *next = arena->next;
+
+ Safefree(arena);
+ arena = next;
+ };
tbl->tbl_items = 0;
+ tbl->tbl_arena = NULL;
+ tbl->tbl_arena_next = NULL;
+ tbl->tbl_arena_end = NULL;
}
}
void
Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
{
+ struct ptr_tbl_arena *arena;
+
if (!tbl) {
return;
}
- ptr_table_clear(tbl);
+
+ arena = tbl->tbl_arena;
+
+ while (arena) {
+ struct ptr_tbl_arena *next = arena->next;
+
+ Safefree(arena);
+ arena = next;
+ }
+
Safefree(tbl->tbl_ary);
Safefree(tbl);
}
PERL_ARGS_ASSERT_RVPV_DUP;
if (SvROK(sstr)) {
- SvRV_set(dstr, SvWEAKREF(sstr)
- ? sv_dup(SvRV_const(sstr), param)
- : sv_dup_inc(SvRV_const(sstr), param));
-
+ if (SvWEAKREF(sstr)) {
+ SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
+ if (param->flags & CLONEf_JOIN_IN) {
+ /* if joining, we add any back references individually rather
+ * than copying the whole backref array */
+ Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr);
+ }
+ }
+ else
+ SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));
}
else if (SvPVX_const(sstr)) {
/* Has something there */
/* duplicate an SV of any type (including AV, HV etc) */
-SV *
-Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
+static SV *
+S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
{
dVAR;
SV *dstr;
- PERL_ARGS_ASSERT_SV_DUP;
+ PERL_ARGS_ASSERT_SV_DUP_COMMON;
- if (!sstr)
- return NULL;
if (SvTYPE(sstr) == SVTYPEMASK) {
#ifdef DEBUG_LEAKING_SCALARS_ABORT
abort();
something that is bad **/
if (SvTYPE(sstr) == SVt_PVHV) {
const HEK * const hvname = HvNAME_HEK(sstr);
- if (hvname)
+ if (hvname) {
/** don't clone stashes if they already exist **/
- return MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
+ dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
+ ptr_table_store(PL_ptr_table, sstr, dstr);
+ return dstr;
+ }
}
}
#endif
if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
- && !isGV_with_GP(dstr))
+ && !isGV_with_GP(dstr)
+ && !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
/* The Copy above means that all the source (unduplicated) pointers
/* Danger Will Robinson - GvGP(dstr) isn't initialised
at the point of this comment. */
GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
- if(param->flags & CLONEf_JOIN_IN) {
- const HEK * const hvname
- = HvNAME_HEK(GvSTASH(dstr));
- if( hvname
- && GvSTASH(dstr) == gv_stashpvn(
- HEK_KEY(hvname), HEK_LEN(hvname), 0
- )
- )
- Perl_sv_add_backref(
- aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr
- );
- }
+ if (param->flags & CLONEf_JOIN_IN)
+ Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
GvGP(dstr) = gp_dup(GvGP(sstr), param);
(void)GpREFCNT_inc(GvGP(dstr));
} else
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
case SVt_PVIO:
- IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
- if (IoOFP(dstr) == IoIFP(sstr))
- IoOFP(dstr) = IoIFP(dstr);
- else
- IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
/* PL_parser->rsfp_filters entries have fake IoDIRP() */
if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
/* I have no idea why fake dirp (rsfps)
NOOP;
/* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
}
+ IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(dstr), param);
}
+ if (IoOFP(dstr) == IoIFP(sstr))
+ IoOFP(dstr) = IoIFP(dstr);
+ else
+ IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
else {
while (items-- > 0)
*dst_ary++ = sv_dup(*src_ary++, param);
- if (!(param->flags & CLONEf_COPY_STACKS)
- && AvREIFY(sstr))
- {
- av_reify(MUTABLE_AV(dstr)); /* #41138 */
- }
}
items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
while (items-- > 0) {
daux->xhv_riter = saux->xhv_riter;
daux->xhv_eiter = saux->xhv_eiter
? he_dup(saux->xhv_eiter,
- (bool)!!HvSHAREKEYS(sstr), param) : 0;
+ cBOOL(HvSHAREKEYS(sstr)), param) : 0;
/* backref array needs refcnt=2; see sv_add_backref */
daux->xhv_backreferences =
- saux->xhv_backreferences
+ (param->flags & CLONEf_JOIN_IN)
+ /* when joining, we let the individual GVs and
+ * CVs add themselves to backref as
+ * needed. This avoids pulling in stuff
+ * that isn't required, and simplifies the
+ * case where stashes aren't cloned back
+ * if they already exist in the parent
+ * thread */
+ ? NULL
+ : saux->xhv_backreferences
? MUTABLE_AV(SvREFCNT_inc(
sv_dup_inc((const SV *)saux->xhv_backreferences, param)))
: 0;
if (!(param->flags & CLONEf_COPY_STACKS)) {
CvDEPTH(dstr) = 0;
}
+ /*FALLTHROUGH*/
case SVt_PVFM:
/* NOTE: not refcounted */
CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
+ if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
+ Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
OP_REFCNT_LOCK;
if (!CvISXSUB(dstr))
CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
}
/* don't dup if copying back - CvGV isn't refcounted, so the
* duped GV may never be freed. A bit of a hack! DAPM */
- CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
- NULL : gv_dup(CvGV(dstr), param) ;
- PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
+ SvANY(MUTABLE_CV(dstr))->xcv_gv =
+ CvCVGV_RC(dstr)
+ ? gv_dup_inc(CvGV(sstr), param)
+ : (param->flags & CLONEf_JOIN_IN)
+ ? NULL
+ : gv_dup(CvGV(sstr), param);
+
+ CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
CvOUTSIDE(dstr) =
CvWEAKOUTSIDE(sstr)
? cv_dup( CvOUTSIDE(dstr), param)
return dstr;
}
+SV *
+Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
+{
+ PERL_ARGS_ASSERT_SV_DUP_INC;
+ return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL;
+}
+
+SV *
+Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
+{
+ SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL;
+ PERL_ARGS_ASSERT_SV_DUP;
+
+ /* Track every SV that (at least initially) had a reference count of 0.
+ We need to do this by holding an actual reference to it in this array.
+ If we attempt to cheat, turn AvREAL_off(), and store only pointers
+ (akin to the stashes hash, and the perl stack), we come unstuck if
+ a weak reference (or other SV legitimately SvREFCNT() == 0 for this
+ thread) is manipulated in a CLONE method, because CLONE runs before the
+ unreferenced array is walked to find SVs still with SvREFCNT() == 0
+ (and fix things up by giving each a reference via the temps stack).
+ Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and
+ then SvREFCNT_dec(), it will be cleaned up (and added to the free list)
+ before the walk of unreferenced happens and a reference to that is SV
+ added to the temps stack. At which point we have the same SV considered
+ to be in use, and free to be re-used. Not good.
+ */
+ if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) {
+ assert(param->unreferenced);
+ av_push(param->unreferenced, SvREFCNT_inc(dstr));
+ }
+
+ return dstr;
+}
+
/* duplicate a context */
PERL_CONTEXT *
#define TOPLONG(ss,ix) ((ss)[ix].any_long)
#define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
#define TOPIV(ss,ix) ((ss)[ix].any_iv)
+#define POPUV(ss,ix) ((ss)[--(ix)].any_uv)
+#define TOPUV(ss,ix) ((ss)[ix].any_uv)
#define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
#define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
#define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
Newxz(nss, max, ANY);
while (ix > 0) {
- const I32 type = POPINT(ss,ix);
- TOPINT(nss,ix) = type;
+ const UV uv = POPUV(ss,ix);
+ const U8 type = (U8)uv & SAVE_MASK;
+
+ TOPUV(nss,ix) = uv;
switch (type) {
+ case SAVEt_CLEARSV:
+ break;
case SAVEt_HELEM: /* hash element */
sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
case SAVEt_LONG: /* long reference */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
- /* fall through */
- case SAVEt_CLEARSV:
longval = (long)POPLONG(ss,ix);
TOPLONG(nss,ix) = longval;
break;
case SAVEt_I32: /* I32 reference */
- case SAVEt_I16: /* I16 reference */
- case SAVEt_I8: /* I8 reference */
case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
case SAVEt_VPTR: /* random* reference */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ /* Fall through */
+ case SAVEt_INT_SMALL:
+ case SAVEt_I32_SMALL:
+ case SAVEt_I16: /* I16 reference */
+ case SAVEt_I8: /* I8 reference */
+ case SAVEt_BOOL:
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
break;
TOPPTR(nss,ix) = pv_dup(c);
break;
case SAVEt_GP: /* scalar reference */
+ gv = (const GV *)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = gv_dup_inc(gv, param);
gp = (GP*)POPPTR(ss,ix);
TOPPTR(nss,ix) = gp = gp_dup(gp, param);
(void)GpREFCNT_inc(gp);
- gv = (const GV *)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup_inc(gv, param);
- break;
+ i = POPINT(ss,ix);
+ TOPINT(nss,ix) = i;
+ break;
case SAVEt_FREEOP:
ptr = POPPTR(ss,ix);
if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
break;
case SAVEt_REGCONTEXT:
case SAVEt_ALLOC:
- i = POPINT(ss,ix);
- TOPINT(nss,ix) = i;
- ix -= i;
+ ix -= uv >> SAVE_TIGHT_SHIFT;
break;
case SAVEt_AELEM: /* array element */
sv = (const SV *)POPPTR(ss,ix);
sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
break;
- case SAVEt_BOOL:
- ptr = POPPTR(ss,ix);
- TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
- longval = (long)POPBOOL(ss,ix);
- TOPBOOL(nss,ix) = (bool)longval;
- break;
case SAVEt_SET_SVFLAGS:
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
#endif /* PERL_IMPLICIT_SYS */
param->flags = flags;
+ /* Nothing in the core code uses this, but we make it available to
+ extensions (using mg_dup). */
param->proto_perl = proto_perl;
+ /* Likely nothing will use this, but it is initialised to be consistent
+ with Perl_clone_params_new(). */
+ param->proto_perl = my_perl;
+ param->unreferenced = NULL;
INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
SvNV_set(&PL_sv_yes, 1);
ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
- /* dbargs array probably holds garbage; give the child a clean array */
- PL_dbargs = newAV();
- ptr_table_store(PL_ptr_table, proto_perl->Idbargs, PL_dbargs);
+ /* dbargs array probably holds garbage */
+ PL_dbargs = NULL;
/* create (a non-shared!) shared string table */
PL_strtab = newHV();
PL_origargv = proto_perl->Iorigargv;
param->stashes = newAV(); /* Setup array of objects to call clone on */
+ /* This makes no difference to the implementation, as it always pushes
+ and shifts pointers to other SVs without changing their reference
+ count, with the array becoming empty before it is freed. However, it
+ makes it conceptually clear what is going on, and will avoid some
+ work inside av.c, filling slots between AvFILL() and AvMAX() with
+ &PL_sv_undef, and SvREFCNT_dec()ing those. */
+ AvREAL_off(param->stashes);
+
+ if (!(flags & CLONEf_COPY_STACKS)) {
+ param->unreferenced = newAV();
+ }
/* Set tainting stuff before PerlIO_debug can possibly get called */
PL_tainting = proto_perl->Itainting;
/* switches */
PL_minus_c = proto_perl->Iminus_c;
PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
+ PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param);
PL_localpatches = proto_perl->Ilocalpatches;
PL_splitstr = proto_perl->Isplitstr;
PL_minus_n = proto_perl->Iminus_n;
PL_unlockhook = proto_perl->Iunlockhook;
PL_threadhook = proto_perl->Ithreadhook;
PL_destroyhook = proto_perl->Idestroyhook;
+ PL_signalhook = proto_perl->Isignalhook;
#ifdef THREADS_HAVE_PIDS
PL_ppid = proto_perl->Ippid;
else {
init_stacks();
ENTER; /* perl_destruct() wants to LEAVE; */
-
- /* although we're not duplicating the tmps stack, we should still
- * add entries for any SVs on the tmps stack that got cloned by a
- * non-refcount means (eg a temp in @_); otherwise they will be
- * orphaned
- */
- for (i = 0; i<= proto_perl->Itmps_ix; i++) {
- SV * const nsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table,
- proto_perl->Itmps_stack[i]));
- if (nsv && !SvREFCNT(nsv)) {
- PUSH_EXTEND_MORTAL__SV_C(SvREFCNT_inc_simple(nsv));
- }
- }
}
PL_start_env = proto_perl->Istart_env; /* XXXXXX */
PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
+ PL_restartjmpenv = proto_perl->Irestartjmpenv;
PL_restartop = proto_perl->Irestartop;
PL_in_eval = proto_perl->Iin_eval;
PL_delaymagic = proto_perl->Idelaymagic;
}
PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
+ PL_blockhooks = av_dup_inc(proto_perl->Iblockhooks, param);
/* Call the ->CLONE method, if it exists, for each of the stashes
identified by sv_dup() above.
PL_ptr_table = NULL;
}
+ if (!(flags & CLONEf_COPY_STACKS)) {
+ unreferenced_to_tmp_stack(param->unreferenced);
+ }
SvREFCNT_dec(param->stashes);
return my_perl;
}
+static void
+S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
+{
+ PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK;
+
+ if (AvFILLp(unreferenced) > -1) {
+ SV **svp = AvARRAY(unreferenced);
+ SV **const last = svp + AvFILLp(unreferenced);
+ SSize_t count = 0;
+
+ do {
+ if (SvREFCNT(*svp) == 1)
+ ++count;
+ } while (++svp <= last);
+
+ EXTEND_MORTAL(count);
+ svp = AvARRAY(unreferenced);
+
+ do {
+ if (SvREFCNT(*svp) == 1) {
+ /* Our reference is the only one to this SV. This means that
+ in this thread, the scalar effectively has a 0 reference.
+ That doesn't work (cleanup never happens), so donate our
+ reference to it onto the save stack. */
+ PL_tmps_stack[++PL_tmps_ix] = *svp;
+ } else {
+ /* As an optimisation, because we are already walking the
+ entire array, instead of above doing either
+ SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead
+ release our reference to the scalar, so that at the end of
+ the array owns zero references to the scalars it happens to
+ point to. We are effectively converting the array from
+ AvREAL() on to AvREAL() off. This saves the av_clear()
+ (triggered by the SvREFCNT_dec(unreferenced) below) from
+ walking the array a second time. */
+ SvREFCNT_dec(*svp);
+ }
+
+ } while (++svp <= last);
+ AvREAL_off(unreferenced);
+ }
+ SvREFCNT_dec(unreferenced);
+}
+
+void
+Perl_clone_params_del(CLONE_PARAMS *param)
+{
+ PerlInterpreter *const was = PERL_GET_THX;
+ PerlInterpreter *const to = param->new_perl;
+ dTHXa(to);
+
+ PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
+
+ if (was != to) {
+ PERL_SET_THX(to);
+ }
+
+ SvREFCNT_dec(param->stashes);
+ if (param->unreferenced)
+ unreferenced_to_tmp_stack(param->unreferenced);
+
+ Safefree(param);
+
+ if (was != to) {
+ PERL_SET_THX(was);
+ }
+}
+
+CLONE_PARAMS *
+Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
+{
+ /* Need to play this game, as newAV() can call safesysmalloc(), and that
+ does a dTHX; to get the context from thread local storage.
+ FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
+ a version that passes in my_perl. */
+ PerlInterpreter *const was = PERL_GET_THX;
+ CLONE_PARAMS *param;
+
+ PERL_ARGS_ASSERT_CLONE_PARAMS_NEW;
+
+ if (was != to) {
+ PERL_SET_THX(to);
+ }
+
+ /* Given that we've set the context, we can do this unshared. */
+ Newx(param, 1, CLONE_PARAMS);
+
+ param->flags = 0;
+ param->proto_perl = from;
+ param->new_perl = to;
+ param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
+ AvREAL_off(param->stashes);
+ param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
+
+ if (was != to) {
+ PERL_SET_THX(was);
+ }
+ return param;
+}
+
#endif /* USE_ITHREADS */
/*
https://perl5.git.perl.org / perl5.git / blobdiff