do_clean_named_objs(pTHX_ SV *sv)
{
dVAR;
- if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
+ if (SvTYPE(sv) == SVt_PVGV && isGV_with_GP(sv) && GvGP(sv)) {
if ((
#ifdef PERL_DONT_CREATE_GVSV
GvSV(sv) &&
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
}
limited by PERL_ARENA_SIZE, so we can safely oversize the
declarations.
*/
-#define FIT_ARENA(count, body_size) \
- (!count || count * body_size > PERL_ARENA_SIZE) \
- ? (int)(PERL_ARENA_SIZE / body_size) * body_size : count * body_size
+#define FIT_ARENA0(body_size) \
+ ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
+#define FIT_ARENAn(count,body_size) \
+ ( count * body_size <= PERL_ARENA_SIZE) \
+ ? count * body_size \
+ : FIT_ARENA0 (body_size)
+#define FIT_ARENA(count,body_size) \
+ count \
+ ? FIT_ARENAn (count, body_size) \
+ : FIT_ARENA0 (body_size)
/* A macro to work out the offset needed to subtract from a pointer to (say)
#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 (((SvFLAGS(sv) & (SVp_POK|SVp_SCREAM)) == SVp_SCREAM)
- && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV)) {
- return PTR2IV(glob_2inpuv((GV *)sv, NULL, TRUE));
+ if (isGV_with_GP(sv)) {
+ return (bool)PTR2IV(glob_2inpuv((GV *)sv, NULL, TRUE));
}
- if (SvTYPE(sv) == SVt_PVGV)
- sv_dump(sv);
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
#endif /* NV_PRESERVES_UV */
}
else {
- if (((SvFLAGS(sv) & (SVp_POK|SVp_SCREAM)) == SVp_SCREAM)
- && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV)) {
+ if (isGV_with_GP(sv)) {
glob_2inpuv((GV *)sv, NULL, TRUE);
return 0.0;
}
#endif
}
else {
- if (((SvFLAGS(sv) & (SVp_POK|SVp_SCREAM)) == SVp_SCREAM)
- && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV)) {
+ if (isGV_with_GP(sv)) {
return glob_2inpuv((GV *)sv, lp, FALSE);
}
if (SvNOKp(sv))
return SvNVX(sv) != 0.0;
else {
- if ((SvFLAGS(sv) & SVp_SCREAM)
- && (SvTYPE(sv) == (SVt_PVGV) || SvTYPE(sv) == (SVt_PVLV)))
+ if (isGV_with_GP(sv))
return TRUE;
else
return FALSE;
const char * const name = GvNAME(sstr);
const STRLEN len = GvNAMELEN(sstr);
/* don't upgrade SVt_PVLV: it can hold a glob */
- if (dtype != SVt_PVLV)
+ if (dtype != SVt_PVLV) {
+ if (dtype >= SVt_PV) {
+ SvPV_free(dstr);
+ SvPV_set(dstr, 0);
+ SvLEN_set(dstr, 0);
+ SvCUR_set(dstr, 0);
+ }
sv_upgrade(dstr, SVt_PVGV);
+ (void)SvOK_off(dstr);
+ SvSCREAM_on(dstr);
+ }
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 */
}
}
#endif
+ gp_free((GV*)dstr);
+ SvSCREAM_off(dstr);
(void)SvOK_off(dstr);
SvSCREAM_on(dstr);
GvINTRO_off(dstr); /* one-shot flag */
- gp_free((GV*)dstr);
GvGP(dstr) = gp_ref(GvGP(sstr));
if (SvTAINTED(sstr))
SvTAINT(dstr);
}
break;
}
- if (dref)
- SvREFCNT_dec(dref);
+ SvREFCNT_dec(dref);
if (SvTAINTED(sstr))
SvTAINT(dstr);
return;
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) {
}
}
else {
- if ((stype == SVt_PVGV || stype == SVt_PVLV)
- && (sflags & SVp_SCREAM)) {
+ if (isGV_with_GP(sstr)) {
/* This stringification rule for globs is spread in 3 places.
This feels bad. FIXME. */
const U32 wasfake = sflags & SVf_FAKE;
mg->mg_obj = obj;
}
else {
- mg->mg_obj = SvREFCNT_inc(obj);
+ mg->mg_obj = SvREFCNT_inc_simple(obj);
mg->mg_flags |= MGf_REFCOUNTED;
}
if (namlen > 0)
mg->mg_ptr = savepvn(name, namlen);
else if (namlen == HEf_SVKEY)
- mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
+ mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV*)name);
else
mg->mg_ptr = (char *) name;
}
MAGIC** mgp;
if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
return 0;
- mgp = &SvMAGIC(sv);
+ mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
for (mg = *mgp; mg; mg = *mgp) {
if (mg->mg_type == type) {
const MGVTBL* const vtbl = mg->mg_virtual;
} else {
av = newAV();
AvREAL_off(av);
- SvREFCNT_inc(av);
+ SvREFCNT_inc_simple_void(av);
}
*avp = av;
}
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))
case SVt_PV:
case SVt_RV:
if (SvROK(sv)) {
- SV *target = SvRV(sv);
+ SV * const target = SvRV(sv);
if (SvWEAKREF(sv))
sv_del_backref(target, sv);
else
if (cur1 == cur2)
eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
- if (svrecode)
- SvREFCNT_dec(svrecode);
-
+ SvREFCNT_dec(svrecode);
if (tpv)
Safefree(tpv);
}
}
- if (svrecode)
- SvREFCNT_dec(svrecode);
-
+ SvREFCNT_dec(svrecode);
if (tpv)
Safefree(tpv);
*/
SV *
-Perl_newRV(pTHX_ SV *tmpRef)
+Perl_newRV(pTHX_ SV *sv)
{
dVAR;
- return newRV_noinc(SvREFCNT_inc(tmpRef));
+ return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
}
/*
if (SvTYPE(tmpRef) != SVt_PVIO)
++PL_sv_objcount;
SvUPGRADE(tmpRef, SVt_PVMG);
- SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
+ SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc_simple(stash));
if (Gv_AMG(stash))
SvAMAGIC_on(sv);
{
dVAR;
void *xpvmg;
- SV *temp = sv_newmortal();
+ SV * const temp = sv_newmortal();
assert(SvTYPE(sv) == SVt_PVGV);
SvFAKE_off(sv);
gv_efullname3(temp, (GV *) sv, "*");
- if (GvGP(sv))
+ if (GvGP(sv)) {
gp_free((GV*)sv);
+ }
if (GvSTASH(sv)) {
sv_del_backref((SV*)GvSTASH(sv), sv);
GvSTASH(sv) = NULL;
}
- SvSCREAM_off(sv);
- Safefree(GvNAME(sv));
GvMULTI_off(sv);
+ if (GvNAME_HEK(sv)) {
+ unshare_hek(GvNAME_HEK(sv));
+ }
+ SvSCREAM_off(sv);
/* need to keep SvANY(sv) in the right arena */
xpvmg = new_XPVMG();
#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)
Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
{
GP *ret;
+
if (!gp)
return (GP*)NULL;
/* look for it in the table first */
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) {
}
else {
/* Special case - not normally malloced for some reason */
- if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
+ if (isGV_with_GP(sstr)) {
+ /* Don't need to do anything here. */
+ }
+ else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
/* A "shared" PV - clone it as "shared" PV */
SvPV_set(dstr,
HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
sv_type_details->body_size + sv_type_details->offset, char);
#endif
- if (sv_type != SVt_PVAV && sv_type != SVt_PVHV)
+ if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
+ && !isGV_with_GP(dstr))
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
/* The Copy above means that all the source (unduplicated) pointers
FIXME - instrument and check that assumption */
if (sv_type >= SVt_PVMG) {
HV *ourstash;
- if ((sv_type == SVt_PVMG || sv_type == SVt_PVGV) &&
- (ourstash = OURSTASH(dstr))) {
+ if ((sv_type == SVt_PVMG) && (ourstash = OURSTASH(dstr))) {
OURSTASH_set(dstr, hv_dup_inc(ourstash, param));
} else if (SvMAGIC(dstr))
SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
break;
case SVt_PVGV:
- GvNAME(dstr) = SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr));
- GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
+ 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. */
- GvGP(dstr) = gp_dup(GvGP(dstr), param);
- (void)GpREFCNT_inc(GvGP(dstr));
+ GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
+ if(isGV_with_GP(sstr)) {
+ /* Danger Will Robinson - GvGP(dstr) isn't initialised
+ at the point of this comment. */
+ 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);
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:
proto_perl->Ttmps_stack[i]);
if (nsv && !SvREFCNT(nsv)) {
EXTEND_MORTAL(1);
- PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc(nsv);
+ PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv);
}
}
}
/* orphaned? eg threads->new inside BEGIN or use */
if (PL_compcv && ! SvREFCNT(PL_compcv)) {
- (void)SvREFCNT_inc(PL_compcv);
+ SvREFCNT_inc_simple_void(PL_compcv);
SAVEFREESV(PL_compcv);
}
https://perl5.git.perl.org / perl5.git / blobdiff