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 */
(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
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;
/* 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)) {
#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);
}
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)) {
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