perl_destruct() to physically free all the arenas allocated since the
start of the interpreter.
-Manipulation of any of the PL_*root pointers is protected by enclosing
-LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
-if threads are enabled.
-
The function visit() scans the SV arenas list, and calls a specified
function for each SV it finds which is still live - ie which has an SvTYPE
other than all 1's, and a non-zero SvREFCNT. visit() is used by the
* "A time to plant, and a time to uproot what was planted..."
*/
-/*
- * nice_chunk and nice_chunk size need to be set
- * and queried under the protection of sv_mutex
- */
void
Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
{
dVAR;
void *new_chunk;
U32 new_chunk_size;
- LOCK_SV_MUTEX;
new_chunk = (void *)(chunk);
new_chunk_size = (chunk_size);
if (new_chunk_size > PL_nice_chunk_size) {
} else {
Safefree(chunk);
}
- UNLOCK_SV_MUTEX;
}
#ifdef DEBUG_LEAKING_SCALARS
--PL_sv_count; \
} STMT_END
-/* sv_mutex must be held while calling uproot_SV() */
#define uproot_SV(p) \
STMT_START { \
(p) = PL_sv_root; \
/* make some more SVs by adding another arena */
-/* sv_mutex must be held while calling more_sv() */
STATIC SV*
S_more_sv(pTHX)
{
{
SV* sv;
- LOCK_SV_MUTEX;
if (PL_sv_root)
uproot_SV(sv);
else
sv = S_more_sv(aTHX);
- UNLOCK_SV_MUTEX;
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
#else
# define new_SV(p) \
STMT_START { \
- LOCK_SV_MUTEX; \
if (PL_sv_root) \
uproot_SV(p); \
else \
(p) = S_more_sv(aTHX); \
- UNLOCK_SV_MUTEX; \
SvANY(p) = 0; \
SvREFCNT(p) = 1; \
SvFLAGS(p) = 0; \
#define del_SV(p) \
STMT_START { \
- LOCK_SV_MUTEX; \
if (DEBUG_D_TEST) \
del_sv(p); \
else \
plant_SV(p); \
- UNLOCK_SV_MUTEX; \
} STMT_END
STATIC void
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
+ 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
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;
- */
+ U32 misc; /* type, and in future other things. */
};
struct arena_set;
struct arena_set {
struct arena_set* next;
- int set_size; /* ie ARENAS_PER_SET */
- int curr; /* index of next available arena-desc */
+ unsigned int set_size; /* ie ARENAS_PER_SET */
+ unsigned int curr; /* index of next available arena-desc */
struct arena_desc set[ARENAS_PER_SET];
};
dVAR;
SV* sva;
SV* svanext;
- int i;
+ unsigned int i;
/* Free arenas here, but be careful about fake ones. (We assume
contiguity of the fake ones with the corresponding real ones.) */
}
{
- struct arena_set *next, *aroot = (struct arena_set*) PL_body_arenas;
-
- for (; aroot; aroot = next) {
- const int max = aroot->curr;
- for (i=0; i<max; i++) {
+ struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
+
+ while (aroot) {
+ struct arena_set *current = aroot;
+ i = aroot->curr;
+ while (i--) {
assert(aroot->set[i].arena);
Safefree(aroot->set[i].arena);
}
- next = aroot->next;
- Safefree(aroot);
+ aroot = aroot->next;
+ Safefree(current);
}
}
PL_body_arenas = 0;
- for (i=0; i<PERL_ARENA_ROOTS_SIZE; i++)
+ i = PERL_ARENA_ROOTS_SIZE;
+ while (i--)
PL_body_roots[i] = 0;
Safefree(PL_nice_chunk);
TBD: export properly for hv.c: S_more_he().
*/
void*
-Perl_get_arena(pTHX_ int arena_size)
+Perl_get_arena(pTHX_ size_t arena_size, U32 misc)
{
dVAR;
struct arena_desc* adesc;
- struct arena_set *newroot, **aroot = (struct arena_set**) &PL_body_arenas;
- int curr;
+ struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
+ unsigned 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) {
+ if (!aroot || aroot->curr >= aroot->set_size) {
+ struct arena_set *newroot;
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", (void*)*aroot));
+ newroot->next = aroot;
+ aroot = newroot;
+ PL_body_arenas = (void *) newroot;
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
}
/* ok, now have arena-set with at least 1 empty/available arena-desc */
- curr = (*aroot)->curr++;
- adesc = &((*aroot)->set[curr]);
+ curr = aroot->curr++;
+ adesc = &(aroot->set[curr]);
assert(!adesc->arena);
- Newxz(adesc->arena, arena_size, char);
+ Newx(adesc->arena, arena_size, char);
adesc->size = arena_size;
+ adesc->misc = misc;
DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %d\n",
curr, (void*)adesc->arena, arena_size));
#define del_body(thing, root) \
STMT_START { \
void ** const thing_copy = (void **)thing;\
- LOCK_SV_MUTEX; \
*thing_copy = *root; \
*root = (void*)thing_copy; \
- UNLOCK_SV_MUTEX; \
} STMT_END
/*
copy_length(XPVAV, xmg_stash)
- relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
+ relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
- SVt_PVAV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) },
+ SVt_PVAV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) },
{ sizeof(xpvhv_allocated),
copy_length(XPVHV, xmg_stash)
- relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
+ relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
- SVt_PVHV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) },
+ SVt_PVHV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) },
/* 56 */
{ sizeof(xpvcv_allocated), sizeof(xpvcv_allocated),
assert(bdp->arena_size);
- start = (char*) Perl_get_arena(aTHX_ bdp->arena_size);
+ start = (char*) Perl_get_arena(aTHX_ bdp->arena_size, sv_type);
end = start + bdp->arena_size - body_size;
#define new_body_inline(xpv, sv_type) \
STMT_START { \
void ** const r3wt = &PL_body_roots[sv_type]; \
- LOCK_SV_MUTEX; \
xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
? *((void **)(r3wt)) : more_bodies(sv_type)); \
*(r3wt) = *(void**)(xpv); \
- UNLOCK_SV_MUTEX; \
} STMT_END
#ifndef PURIFY
* NV slot, but the new one does, then we need to initialise the
* freshly created NV slot with whatever the correct bit pattern is
* for 0.0 */
- if (old_type_details->zero_nv && !new_type_details->zero_nv)
+ if (old_type_details->zero_nv && !new_type_details->zero_nv
+ && !isGV_with_GP(sv))
SvNV_set(sv, 0);
#endif
Copies a stringified representation of the source SV into the
destination SV. Automatically performs any necessary mg_get and
coercion of numeric values into strings. Guaranteed to preserve
-UTF-8 flag even from overloaded objects. Similar in nature to
+UTF8 flag even from overloaded objects. Similar in nature to
sv_2pv[_flags] but operates directly on an SV instead of just the
string. Mostly uses sv_2pv_flags to do its work, except when that
would lose the UTF-8'ness of the PV.
stype = SvTYPE(sstr);
dtype = SvTYPE(dstr);
- SvAMAGIC_off(dstr);
+ (void)SvAMAGIC_off(dstr);
if ( SvVOK(dstr) )
{
/* need to nuke the magic */
dVAR;
MAGIC* mg;
- if (SvTYPE(sv) < SVt_PVMG) {
- SvUPGRADE(sv, SVt_PVMG);
- }
+ SvUPGRADE(sv, SVt_PVMG);
Newxz(mg, 1, MAGIC);
mg->mg_moremagic = SvMAGIC(sv);
SvMAGIC_set(sv, mg);
}
/*
+=for apidoc newSV_type
+
+Creates a new SV, of the type specificied. The reference count for the new SV
+is set to 1.
+
+=cut
+*/
+
+SV *
+Perl_newSV_type(pTHX_ svtype type)
+{
+ register SV *sv;
+
+ new_SV(sv);
+ sv_upgrade(sv, type);
+ return sv;
+}
+
+/*
=for apidoc newRV_noinc
Creates an RV wrapper for an SV. The reference count for the original
Perl_newRV_noinc(pTHX_ SV *tmpRef)
{
dVAR;
- register SV *sv;
-
- new_SV(sv);
- sv_upgrade(sv, SVt_RV);
+ register SV *sv = newSV_type(SVt_RV);
SvTEMP_off(tmpRef);
SvRV_set(sv, tmpRef);
SvROK_on(sv);
new_SV(sv);
SV_CHECK_THINKFIRST_COW_DROP(rv);
- SvAMAGIC_off(rv);
+ (void)SvAMAGIC_off(rv);
if (SvTYPE(rv) >= SVt_PVMG) {
const U32 refcnt = SvREFCNT(rv);
SvROK_on(rv);
if (classname) {
- HV* const stash = gv_stashpv(classname, TRUE);
+ HV* const stash = gv_stashpv(classname, GV_ADD);
(void)sv_bless(rv, stash);
}
return sv;
if (Gv_AMG(stash))
SvAMAGIC_on(sv);
else
- SvAMAGIC_off(sv);
+ (void)SvAMAGIC_off(sv);
if(SvSMAGICAL(tmpRef))
if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
TOPPTR(nss,ix) = ptr;
o = (OP*)ptr;
OP_REFCNT_LOCK;
- OpREFCNT_inc(o);
+ (void) OpREFCNT_inc(o);
OP_REFCNT_UNLOCK;
break;
default:
= pv_dup(old_state->re_state_reginput);
new_state->re_state_regeol
= pv_dup(old_state->re_state_regeol);
- new_state->re_state_regstartp
- = (I32*) any_dup(old_state->re_state_regstartp, proto_perl);
- new_state->re_state_regendp
- = (I32*) any_dup(old_state->re_state_regendp, proto_perl);
+ new_state->re_state_regoffs
+ = (regexp_paren_pair*)
+ any_dup(old_state->re_state_regoffs, proto_perl);
new_state->re_state_reglastparen
= (U32*) any_dup(old_state->re_state_reglastparen,
proto_perl);
break;
case SAVEt_PARSER:
ptr = POPPTR(ss,ix);
- TOPPTR(nss,ix) = parser_dup(ptr, param);
+ TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
break;
default:
Perl_croak(aTHX_
with it we copy the stacks and the new perl interpreter is
ready to run at the exact same point as the previous one.
The pseudo-fork code uses COPY_STACKS while the
-threads->new doesn't.
+threads->create doesn't.
CLONEf_KEEP_PTR_TABLE
perl_clone keeps a ptr_table with the pointer of the old
Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
#ifdef PERL_GLOBAL_STRUCT_PRIVATE
- Newx(PL_my_cxt_keys, PL_my_cxt_size, char *);
+ Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
#endif
}
else {
PL_my_cxt_list = (void**)NULL;
#ifdef PERL_GLOBAL_STRUCT_PRIVATE
- PL_my_cxt_keys = (void**)NULL;
+ PL_my_cxt_keys = (const char**)NULL;
#endif
}
PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
case OP_PRTF:
case OP_PRINT:
+ case OP_SAY:
/* skip filehandle as it can't produce 'undef' warning */
o = cUNOPx(obase)->op_first;
if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
https://perl5.git.perl.org / perl5.git / blobdiff