return cleaned;
}
+/*
+ ARENASETS: a meta-arena implementation which separates arena-info
+ into struct arena_set, which contains an array of struct
+ arena_descs, each holding info for a single arena. By separating
+ the meta-info from the arena, we recover the 1st slot, formerly
+ borrowed for list management. The arena_set is about the size of an
+ arena, avoiding the needless malloc overhead of a naive linked-list
+
+ The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
+ memory in the last arena-set (1/2 on average). In trade, we get
+ back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
+ others)
+
+ union arena is declared with a fixed size, but is intended to vary
+ by type, allowing their use for big, rare body-types where theres
+ currently too much wastage (unused arena slots)
+*/
+#define ARENASETS 1
+
+struct arena_desc {
+ char *arena; /* the raw storage, allocated aligned */
+ size_t size; /* its size ~4k typ */
+ int unit_type; /* useful for arena audits */
+ /* info for sv-heads (eventually)
+ int count, flags;
+ */
+};
+
+struct arena_set;
+
+/* Get the maximum number of elements in set[] such that struct arena_set
+ will fit within PERL_ARENA_SIZE, which is probabably just under 4K, and
+ therefore likely to be 1 aligned memory page. */
+
+#define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
+ - 2 * sizeof(int)) / sizeof (struct arena_desc))
+
+struct arena_set {
+ struct arena_set* next;
+ int set_size; /* ie ARENAS_PER_SET */
+ int curr; /* index of next available arena-desc */
+ struct arena_desc set[ARENAS_PER_SET];
+};
+
+#if !ARENASETS
+
static void
S_free_arena(pTHX_ void **root) {
while (root) {
root = next;
}
}
-
+#endif
+
/*
=for apidoc sv_free_arenas
Safefree(sva);
}
+#if ARENASETS
+ {
+ struct arena_set *next, *aroot = (struct arena_set*) PL_body_arenas;
+
+ for (; aroot; aroot = next) {
+ int max = aroot->curr;
+ for (i=0; i<max; i++) {
+ assert(aroot->set[i].arena);
+ Safefree(aroot->set[i].arena);
+ }
+ next = aroot->next;
+ Safefree(aroot);
+ }
+ }
+#else
S_free_arena(aTHX_ (void**) PL_body_arenas);
+#endif
for (i=0; i<SVt_LAST; i++)
PL_body_roots[i] = 0;
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.
+ 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, PERL_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;
+
+ /* shouldnt need this
+ if (!arena_size) arena_size = PERL_ARENA_SIZE;
+ */
+
+ /* may need new arena-set to hold new arena */
+ if (!*aroot || (*aroot)->curr >= (*aroot)->set_size) {
+ Newxz(newroot, 1, struct arena_set);
+ newroot->set_size = ARENAS_PER_SET;
+ newroot->next = *aroot;
+ *aroot = newroot;
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", *aroot));
+ }
+
+ /* ok, now have arena-set with at least 1 empty/available arena-desc */
+ curr = (*aroot)->curr++;
+ adesc = &((*aroot)->set[curr]);
+ assert(!adesc->arena);
+
+ Newxz(adesc->arena, arena_size, char);
+ adesc->size = arena_size;
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p\n", curr, aroot));
+
+ return adesc->arena;
+#endif
+}
+
STATIC void *
S_more_bodies (pTHX_ size_t size, svtype sv_type)
{
const char *end;
const size_t count = PERL_ARENA_SIZE / size;
- Newx(start, count*size, char);
- *((void **) start) = PL_body_arenas;
- PL_body_arenas = (void *)start;
+ start = (char*) Perl_get_arena(aTHX_ PERL_ARENA_SIZE);
end = start + (count-1) * 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 += size;
+#endif
*root = (void *)start;
};
#define new_body_type(sv_type) \
- (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\
- - bodies_by_type[sv_type].offset)
+ (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type))
#define del_body_type(p, sv_type) \
del_body(p, &PL_body_roots[sv_type])
const U32 old_type = SvTYPE(sv);
const struct body_details *const old_type_details
= bodies_by_type + old_type;
- const struct body_details *new_type_details = bodies_by_type + new_type;
+ const struct body_details *new_type_details;
if (new_type != SVt_PV && SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
if (new_type < SVt_PVIV) {
new_type = (new_type == SVt_NV)
? SVt_PVNV : SVt_PVIV;
- new_type_details = bodies_by_type + new_type;
}
break;
case SVt_NV:
if (new_type < SVt_PVNV) {
new_type = SVt_PVNV;
- new_type_details = bodies_by_type + new_type;
}
break;
case SVt_RV:
break;
default:
if (old_type_details->cant_upgrade)
- Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
+ Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
+ sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
}
+ new_type_details = bodies_by_type + new_type;
SvFLAGS(sv) &= ~SVTYPEMASK;
SvFLAGS(sv) |= new_type;
+ /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
+ the return statements above will have triggered. */
+ assert (new_type != SVt_NULL);
switch (new_type) {
- case SVt_NULL:
- Perl_croak(aTHX_ "Can't upgrade to undef");
case SVt_IV:
assert(old_type == SVt_NULL);
SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
SvRV_set(sv, 0);
return;
case SVt_PVHV:
- SvANY(sv) = new_XPVHV();
- HvFILL(sv) = 0;
- HvMAX(sv) = 0;
- HvTOTALKEYS(sv) = 0;
-
- goto hv_av_common;
-
case SVt_PVAV:
- SvANY(sv) = new_XPVAV();
- AvMAX(sv) = -1;
- AvFILLp(sv) = -1;
- AvALLOC(sv) = 0;
- AvREAL_only(sv);
+ assert(new_type_details->size);
+
+#ifndef PURIFY
+ assert(new_type_details->arena);
+ /* This points to the start of the allocated area. */
+ new_body_inline(new_body, new_type_details->size, new_type);
+ Zero(new_body, new_type_details->size, char);
+ new_body = ((char *)new_body) - new_type_details->offset;
+#else
+ /* We always allocated the full length item with PURIFY. To do this
+ we fake things so that arena is false for all 16 types.. */
+ new_body = new_NOARENAZ(new_type_details);
+#endif
+ SvANY(sv) = new_body;
+ if (new_type == SVt_PVAV) {
+ AvMAX(sv) = -1;
+ AvFILLp(sv) = -1;
+ AvREAL_only(sv);
+ }
- hv_av_common:
/* SVt_NULL isn't the only thing upgraded to AV or HV.
The target created by newSVrv also is, and it can have magic.
However, it never has SvPVX set.
if (old_type >= SVt_PVMG) {
SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic);
SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
- } else {
- SvMAGIC_set(sv, NULL);
- SvSTASH_set(sv, NULL);
}
break;
*/
static void
-S_glob_assign(pTHX_ SV *dstr, SV *sstr, const int dtype)
+S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype)
{
if (dtype != SVt_PVGV) {
const char * const name = GvNAME(sstr);
}
static void
-S_pvgv_assign(pTHX_ SV *dstr, SV *sstr) {
+S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) {
SV * const sref = SvREFCNT_inc(SvRV(sstr));
SV *dref = NULL;
const int intro = GvINTRO(dstr);
+ SV **location;
+ U8 import_flag = 0;
+ const U32 stype = SvTYPE(sref);
+
#ifdef GV_UNIQUE_CHECK
if (GvUNIQUE((GV*)dstr)) {
GvEGV(dstr) = (GV*)dstr;
}
GvMULTI_on(dstr);
- switch (SvTYPE(sref)) {
- case SVt_PVAV:
- if (intro)
- SAVEGENERICSV(GvAV(dstr));
- else
- dref = (SV*)GvAV(dstr);
- GvAV(dstr) = (AV*)sref;
- if (!GvIMPORTED_AV(dstr)
- && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
- {
- GvIMPORTED_AV_on(dstr);
- }
- break;
- case SVt_PVHV:
- if (intro)
- SAVEGENERICSV(GvHV(dstr));
- else
- dref = (SV*)GvHV(dstr);
- GvHV(dstr) = (HV*)sref;
- if (!GvIMPORTED_HV(dstr)
- && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
- {
- GvIMPORTED_HV_on(dstr);
- }
- break;
+ switch (stype) {
case SVt_PVCV:
+ location = (SV **) &GvCV(dstr);
+ import_flag = GVf_IMPORTED_CV;
+ goto common;
+ case SVt_PVHV:
+ location = (SV **) &GvHV(dstr);
+ import_flag = GVf_IMPORTED_HV;
+ goto common;
+ case SVt_PVAV:
+ location = (SV **) &GvAV(dstr);
+ import_flag = GVf_IMPORTED_AV;
+ goto common;
+ case SVt_PVIO:
+ location = (SV **) &GvIOp(dstr);
+ goto common;
+ case SVt_PVFM:
+ location = (SV **) &GvFORM(dstr);
+ default:
+ location = &GvSV(dstr);
+ import_flag = GVf_IMPORTED_SV;
+ common:
if (intro) {
- if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
- SvREFCNT_dec(GvCV(dstr));
- GvCV(dstr) = NULL;
- GvCVGEN(dstr) = 0; /* Switch off cacheness. */
- PL_sub_generation++;
+ if (stype == SVt_PVCV) {
+ if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
+ SvREFCNT_dec(GvCV(dstr));
+ GvCV(dstr) = NULL;
+ GvCVGEN(dstr) = 0; /* Switch off cacheness. */
+ PL_sub_generation++;
+ }
}
- SAVEGENERICSV(GvCV(dstr));
+ SAVEGENERICSV(*location);
}
else
- dref = (SV*)GvCV(dstr);
- if (GvCV(dstr) != (CV*)sref) {
- CV* const cv = GvCV(dstr);
+ dref = *location;
+ if (stype == SVt_PVCV && *location != sref) {
+ CV* const cv = (CV*)*location;
if (cv) {
if (!GvCVGEN((GV*)dstr) &&
(CvROOT(cv) || CvXSUB(cv)))
cv_ckproto(cv, (GV*)dstr,
SvPOK(sref) ? SvPVX_const(sref) : NULL);
}
- GvCV(dstr) = (CV*)sref;
GvCVGEN(dstr) = 0; /* Switch off cacheness. */
GvASSUMECV_on(dstr);
PL_sub_generation++;
}
- if (!GvIMPORTED_CV(dstr) && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
- GvIMPORTED_CV_on(dstr);
- }
- break;
- case SVt_PVIO:
- if (intro)
- SAVEGENERICSV(GvIOp(dstr));
- else
- dref = (SV*)GvIOp(dstr);
- GvIOp(dstr) = (IO*)sref;
- break;
- case SVt_PVFM:
- if (intro)
- SAVEGENERICSV(GvFORM(dstr));
- else
- dref = (SV*)GvFORM(dstr);
- GvFORM(dstr) = (CV*)sref;
- break;
- default:
- if (intro)
- SAVEGENERICSV(GvSV(dstr));
- else
- dref = (SV*)GvSV(dstr);
- GvSV(dstr) = sref;
- if (!GvIMPORTED_SV(dstr) && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
- GvIMPORTED_SV_on(dstr);
+ *location = sref;
+ if (import_flag && !(GvFLAGS(dstr) & import_flag)
+ && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
+ GvFLAGS(dstr) |= import_flag;
}
break;
}
case SVt_RV:
if (dtype < SVt_RV)
sv_upgrade(dstr, SVt_RV);
- else if (dtype == SVt_PVGV &&
- SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
- sstr = SvRV(sstr);
- if (sstr == dstr) {
- if (GvIMPORTED(dstr) != GVf_IMPORTED
- && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
- {
- GvIMPORTED_on(dstr);
- }
- GvMULTI_on(dstr);
- return;
- }
- S_glob_assign(aTHX_ dstr, sstr, dtype);
- return;
- }
break;
case SVt_PVFM:
#ifdef PERL_OLD_COPY_ON_WRITE
case SVt_PVGV:
if (dtype <= SVt_PVGV) {
- S_glob_assign(aTHX_ dstr, sstr, dtype);
+ S_glob_assign_glob(aTHX_ dstr, sstr, dtype);
return;
}
/* FALL THROUGH */
if ((int)SvTYPE(sstr) != stype) {
stype = SvTYPE(sstr);
if (stype == SVt_PVGV && dtype <= SVt_PVGV) {
- S_glob_assign(aTHX_ dstr, sstr, dtype);
+ S_glob_assign_glob(aTHX_ dstr, sstr, dtype);
return;
}
}
sflags = SvFLAGS(sstr);
if (sflags & SVf_ROK) {
+ if (dtype == SVt_PVGV &&
+ SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
+ sstr = SvRV(sstr);
+ if (sstr == dstr) {
+ if (GvIMPORTED(dstr) != GVf_IMPORTED
+ && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
+ {
+ GvIMPORTED_on(dstr);
+ }
+ GvMULTI_on(dstr);
+ return;
+ }
+ S_glob_assign_glob(aTHX_ dstr, sstr, dtype);
+ return;
+ }
+
if (dtype >= SVt_PV) {
if (dtype == SVt_PVGV) {
- S_pvgv_assign(aTHX_ dstr, sstr);
+ S_glob_assign_ref(aTHX_ dstr, sstr);
return;
}
if (SvPVX_const(dstr)) {
SvIV_set(dstr, SvIVX(sstr));
}
if (sflags & SVp_NOK) {
- SvFLAGS(dstr) |= sflags & (SVf_NOK|SVp_NOK);
SvNV_set(dstr, SvNVX(sstr));
}
}
GV *gv = NULL;
CV *cv = NULL;
- if (!sv)
- return *st = NULL, *gvp = NULL, NULL;
+ if (!sv) {
+ *st = NULL;
+ *gvp = NULL;
+ return NULL;
+ }
switch (SvTYPE(sv)) {
case SVt_PVCV:
*st = CvSTASH(sv);
param->flags = flags;
param->proto_perl = proto_perl;
+ INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
+
PL_body_arenas = NULL;
Zero(&PL_body_roots, 1, PL_body_roots);
projects / p5sagit/p5-mst-13.2.git / blobdiff