struct arena_desc set[ARENAS_PER_SET];
};
-#if !ARENASETS
-
-static void
-S_free_arena(pTHX_ void **root) {
- while (root) {
- void ** const next = *(void **)root;
- Safefree(root);
- root = next;
- }
-}
-#endif
-
/*
=for apidoc sv_free_arenas
Safefree(sva);
}
-#if ARENASETS
{
struct arena_set *next, *aroot = (struct arena_set*) PL_body_arenas;
Safefree(aroot);
}
}
-#else
- S_free_arena(aTHX_ (void**) PL_body_arenas);
-#endif
PL_body_arenas = 0;
for (i=0; i<PERL_ARENA_ROOTS_SIZE; i++)
contexts below (line ~10k)
*/
-/* get_arena(size): when ARENASETS is enabled, this creates
- custom-sized arenas, otherwize it uses PERL_ARENA_SIZE, as
- previously done.
+/* get_arena(size): this creates custom-sized arenas
TBD: export properly for hv.c: S_more_he().
*/
void*
Perl_get_arena(pTHX_ int arena_size)
{
-#if !ARENASETS
- union arena* arp;
-
- /* allocate and attach arena */
- Newx(arp, arena_size, char);
- arp->next = PL_body_arenas;
- PL_body_arenas = arp;
- return arp;
-
-#else
struct arena_desc* adesc;
struct arena_set *newroot, **aroot = (struct arena_set**) &PL_body_arenas;
int curr;
curr, adesc->arena, arena_size));
return adesc->arena;
-#endif
}
#ifdef DEBUGGING
if (!done_sanity_check) {
- int i = SVt_LAST;
+ unsigned int i = SVt_LAST;
done_sanity_check = TRUE;
end = start + bdp->arena_size - body_size;
-#if !ARENASETS
- /* The initial slot is used to link the arenas together, so it isn't to be
- linked into the list of ready-to-use bodies. */
- start += body_size;
-#else
/* computed count doesnt reflect the 1st slot reservation */
DEBUG_m(PerlIO_printf(Perl_debug_log,
"arena %p end %p arena-size %d type %d size %d ct %d\n",
start, end, bdp->arena_size, sv_type, body_size,
bdp->arena_size / body_size));
-#endif
*root = (void *)start;
SvANY(sv) = new_body;
if (old_type_details->copy) {
- Copy((char *)old_body + old_type_details->offset,
- (char *)new_body + old_type_details->offset,
- old_type_details->copy, char);
+ /* There is now the potential for an upgrade from something without
+ an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
+ int offset = old_type_details->offset;
+ int length = old_type_details->copy;
+
+ if (new_type_details->offset > old_type_details->offset) {
+ int difference
+ = new_type_details->offset - old_type_details->offset;
+ offset += difference;
+ length -= difference;
+ }
+ assert (length >= 0);
+
+ Copy((char *)old_body + offset, (char *)new_body + offset, length,
+ char);
}
#ifndef NV_ZERO_IS_ALLBITS_ZERO
{
register char *s;
+ if (PL_madskills && newlen >= 0x100000) {
+ PerlIO_printf(Perl_debug_log,
+ "Allocation too large: %"UVxf"\n", (UV)newlen);
+ }
#ifdef HAS_64K_LIMIT
if (newlen >= 0x10000) {
PerlIO_printf(Perl_debug_log,
}
else {
if (isGV_with_GP(sv)) {
- return PTR2IV(glob_2inpuv((GV *)sv, NULL, TRUE));
+ return (bool)PTR2IV(glob_2inpuv((GV *)sv, NULL, TRUE));
}
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
GvSTASH(dstr) = GvSTASH(sstr);
if (GvSTASH(dstr))
Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
- GvNAME(dstr) = savepvn(name, len);
- GvNAMELEN(dstr) = len;
+ gv_name_set((GV *)dstr, name, len, GV_ADD);
SvFAKE_on(dstr); /* can coerce to non-glob */
}
if (dtype < SVt_PVNV)
sv_upgrade(dstr, SVt_PVNV);
break;
- case SVt_PVAV:
- case SVt_PVHV:
- case SVt_PVCV:
- case SVt_PVIO:
+ default:
{
const char * const type = sv_reftype(sstr,0);
if (PL_op)
}
/*FALLTHROUGH*/
- default:
+ case SVt_PVMG:
+ case SVt_PVLV:
+ case SVt_PVBM:
if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
mg_get(sstr);
if ((int)SvTYPE(sstr) != stype) {
goto freescalar;
case SVt_PVGV:
gp_free((GV*)sv);
- Safefree(GvNAME(sv));
+ if (GvNAME_HEK(sv)) {
+ unshare_hek(GvNAME_HEK(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 (GvSTASH(sv))
*/
SV *
-Perl_newRV(pTHX_ SV *tmpRef)
+Perl_newRV(pTHX_ SV *sv)
{
dVAR;
- return newRV_noinc(SvREFCNT_inc_simple(tmpRef));
+ return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
}
/*
GvSTASH(sv) = NULL;
}
GvMULTI_off(sv);
- Safefree(GvNAME(sv));
+ if (GvNAME_HEK(sv)) {
+ unshare_hek(GvNAME_HEK(sv));
+ }
SvSCREAM_off(sv);
/* need to keep SvANY(sv) in the right arena */
#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 av_dup(s,t) (AV*)sv_dup((SV*)s,t)
#define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
#define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
void
Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
{
- PTR_TBL_ENT_t *tblent = S_ptr_table_find(tbl, oldsv);
+ PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
PERL_UNUSED_CONTEXT;
if (tblent) {
LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
break;
case SVt_PVGV:
- GvNAME(dstr) = SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr));
+ if (GvNAME_HEK(dstr))
+ GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
+
/* Don't call sv_add_backref here as it's going to be created
as part of the magic cloning of the symbol table. */
GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
const I32 len = av_len((AV*)proto_perl->Iregex_padav);
SV* const * const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
IV i;
- av_push(PL_regex_padav,
- sv_dup_inc(regexen[0],param));
+ av_push(PL_regex_padav, sv_dup_inc_NN(regexen[0],param));
for(i = 1; i <= len; i++) {
const SV * const regex = regexen[i];
SV * const sv =
i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
+#ifdef PERL_MAD
+ Copy(proto_perl->Inexttoke, PL_nexttoke, 5, NEXTTOKE);
+ PL_lasttoke = proto_perl->Ilasttoke;
+ PL_realtokenstart = proto_perl->Irealtokenstart;
+ PL_faketokens = proto_perl->Ifaketokens;
+ PL_thismad = proto_perl->Ithismad;
+ PL_thistoken = proto_perl->Ithistoken;
+ PL_thisopen = proto_perl->Ithisopen;
+ PL_thisstuff = proto_perl->Ithisstuff;
+ PL_thisclose = proto_perl->Ithisclose;
+ PL_thiswhite = proto_perl->Ithiswhite;
+ PL_nextwhite = proto_perl->Inextwhite;
+ PL_skipwhite = proto_perl->Iskipwhite;
+ PL_endwhite = proto_perl->Iendwhite;
+ PL_curforce = proto_perl->Icurforce;
+#else
Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
PL_nexttoke = proto_perl->Inexttoke;
+#endif
/* XXX This is probably masking the deeper issue of why
* SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case: