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 */
FIT_ARENA(24, sizeof(XPVIO) - STRUCT_OFFSET(XPVIO, xpv_cur)) },
};
-#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 */
break;
+ case SVt_REGEXP:
+ /* This ensures that SvTHINKFIRST(sv) is true, and hence that
+ sv_force_normal_flags(sv) is called. */
+ SvFAKE_on(sv);
case SVt_PVIV:
/* XXX Is this still needed? Was it ever needed? Surely as there is
no route from NV to PVIV, NOK can never be true */
case SVt_PVGV:
case SVt_PVCV:
case SVt_PVLV:
- case SVt_REGEXP:
case SVt_PVMG:
case SVt_PVNV:
case SVt_PV:
if (new_type == SVt_PVIO) {
IO * const io = MUTABLE_IO(sv);
- GV *iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
+ GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
SvOBJECT_on(io);
/* Clear the stashcache because a new IO could overrule a package
(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
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);
}
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);
if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
/* Unwrap this: */
/* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
gv_efullname3(buffer, gv, "*");
SvFLAGS(gv) |= wasfake;
- assert(SvPOK(buffer));
- if (lp) {
- *lp = SvCUR(buffer);
+ if (SvPOK(buffer)) {
+ if (lp) {
+ *lp = SvCUR(buffer);
+ }
+ return SvPVX(buffer);
+ }
+ else {
+ if (lp)
+ *lp = 0;
+ return (char *)"";
}
- return SvPVX(buffer);
}
if (lp)
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 **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
sv_unref_flags(sv, flags);
else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
sv_unglob(sv);
+ else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
+ /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous
+ to sv_unglob. We only need it here, so inline it. */
+ const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
+ SV *const temp = newSV_type(new_type);
+ void *const temp_p = SvANY(sv);
+
+ if (new_type == SVt_PVMG) {
+ SvMAGIC_set(temp, SvMAGIC(sv));
+ SvMAGIC_set(sv, NULL);
+ SvSTASH_set(temp, SvSTASH(sv));
+ SvSTASH_set(sv, NULL);
+ }
+ SvCUR_set(temp, SvCUR(sv));
+ /* Remember that SvPVX is in the head, not the body. */
+ if (SvLEN(temp)) {
+ SvLEN_set(temp, SvLEN(sv));
+ /* This signals "buffer is owned by someone else" in sv_clear,
+ which is the least effort way to stop it freeing the buffer.
+ */
+ SvLEN_set(sv, SvLEN(sv)+1);
+ } else {
+ /* Their buffer is already owned by someone else. */
+ SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
+ SvLEN_set(temp, SvCUR(sv)+1);
+ }
+
+ /* Now swap the rest of the bodies. */
+
+ SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
+ SvFLAGS(sv) |= new_type;
+ SvANY(sv) = SvANY(temp);
+
+ SvFLAGS(temp) &= ~(SVTYPEMASK);
+ SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
+ SvANY(temp) = temp_p;
+
+ SvREFCNT_dec(temp);
+ }
}
/*
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;
&& !CvCONST(destructor)
/* Don't bother calling an empty destructor */
&& (CvISXSUB(destructor)
- || CvSTART(destructor)->op_next->op_type != OP_LEAVESUB))
+ || (CvSTART(destructor)
+ && (CvSTART(destructor)->op_next->op_type != OP_LEAVESUB))))
{
SV* const tmpref = newRV(sv);
SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
/* 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)) {
}
assert(mg);
mg->mg_len = ulen;
+ /* For now, treat "overflowed" as "still unknown".
+ See RT #72924. */
+ if (ulen != (STRLEN) mg->mg_len)
+ mg->mg_len = -1;
}
}
return ulen;
/*
-=for apidoc sv_pos_u2b
+=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() 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(pTHX_ register SV *const sv, I32 *const offsetp, I32 *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;
-
- if (!sv)
- return;
+ PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
- start = (U8*)SvPV_const(sv, len);
+ start = (U8*)SvPV_flags(sv, len, flags);
if (len) {
- STRLEN uoffset = (STRLEN) *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 = (I32) boffset;
+ boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
if (lenp) {
/* Convert the relative offset to absolute. */
- const STRLEN uoffset2 = uoffset + (STRLEN) *lenp;
+ const STRLEN uoffset2 = uoffset + *lenp;
const STRLEN boffset2
= sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
uoffset, boffset) - boffset;
*lenp = boffset2;
}
- }
- else {
- *offsetp = 0;
- if (lenp)
- *lenp = 0;
+ } else {
+ if (lenp)
+ *lenp = 0;
+ boffset = 0;
}
- return;
+ return boffset;
+}
+
+/*
+=for apidoc sv_pos_u2b
+
+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.
+
+Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
+than 2Gb.
+
+=cut
+*/
+
+/*
+ * sv_pos_u2b() 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().
+ *
+ */
+
+/* This function is subject to size and sign problems */
+
+void
+Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
+{
+ PERL_ARGS_ASSERT_SV_POS_U2B;
+
+ if (lenp) {
+ STRLEN ulen = (STRLEN)*lenp;
+ *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
+ SV_GMAGIC|SV_CONST_RETURN);
+ *lenp = (I32)ulen;
+ } else {
+ *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
+ SV_GMAGIC|SV_CONST_RETURN);
+ }
}
/* Create and update the UTF8 magic offset cache, with the proffered utf8/
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;
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);
}
/* =========================================================================
#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;
}
/* 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);
}
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
#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;
PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
PERL_ARGS_ASSERT_PERL_CLONE_USING;
-
- /* for each stash, determine whether its objects should be cloned */
- S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
- PERL_SET_THX(my_perl);
-
-# ifdef DEBUGGING
- PoisonNew(my_perl, 1, PerlInterpreter);
- PL_op = NULL;
- PL_curcop = NULL;
- PL_markstack = 0;
- PL_scopestack = 0;
- PL_scopestack_name = 0;
- PL_savestack = 0;
- PL_savestack_ix = 0;
- PL_savestack_max = -1;
- PL_sig_pending = 0;
- PL_parser = NULL;
- Zero(&PL_debug_pad, 1, struct perl_debug_pad);
-# else /* !DEBUGGING */
- Zero(my_perl, 1, PerlInterpreter);
-# endif /* DEBUGGING */
#else /* !PERL_IMPLICIT_SYS */
IV i;
CLONE_PARAMS clone_params;
PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
PERL_ARGS_ASSERT_PERL_CLONE;
+#endif /* PERL_IMPLICIT_SYS */
/* for each stash, determine whether its objects should be cloned */
S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
PERL_SET_THX(my_perl);
-# ifdef DEBUGGING
+#ifdef DEBUGGING
PoisonNew(my_perl, 1, PerlInterpreter);
PL_op = NULL;
PL_curcop = NULL;
PL_sig_pending = 0;
PL_parser = NULL;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
-# else /* !DEBUGGING */
+# ifdef DEBUG_LEAKING_SCALARS
+ PL_sv_serial = (((U32)my_perl >> 2) & 0xfff) * 1000000;
+# endif
+#else /* !DEBUGGING */
Zero(my_perl, 1, PerlInterpreter);
-# endif /* DEBUGGING */
-#endif /* PERL_IMPLICIT_SYS */
+#endif /* DEBUGGING */
#ifdef PERL_IMPLICIT_SYS
/* host pointers */
SvNV_set(&PL_sv_yes, 1);
ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
+ /* dbargs array probably holds garbage */
+ PL_dbargs = NULL;
+
/* create (a non-shared!) shared string table */
PL_strtab = newHV();
HvSHAREKEYS_off(PL_strtab);
PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
- PL_dbargs = av_dup(proto_perl->Idbargs, param);
/* symbol tables */
PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
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;
https://perl5.git.perl.org / perl5.git / blobdiff