new_SV(), del_SV(),
- new_XIV(), del_XIV(),
- new_XNV(), del_XNV(),
+ new_XPVNV(), del_XPVGV(),
etc
Public API:
* "A time to plant, and a time to uproot what was planted..."
*/
-void
-Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size)
-{
- dVAR;
- void *new_chunk;
- U32 new_chunk_size;
-
- PERL_ARGS_ASSERT_OFFER_NICE_CHUNK;
-
- new_chunk = (void *)(chunk);
- new_chunk_size = (chunk_size);
- if (new_chunk_size > PL_nice_chunk_size) {
- Safefree(PL_nice_chunk);
- PL_nice_chunk = (char *) new_chunk;
- PL_nice_chunk_size = new_chunk_size;
- } else {
- Safefree(chunk);
- }
-}
-
#ifdef PERL_MEM_LOG
# define MEM_LOG_NEW_SV(sv, file, line, func) \
Perl_mem_log_new_sv(sv, file, line, func)
{
dVAR;
SV* sv;
-
- if (PL_nice_chunk) {
- sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
- PL_nice_chunk = NULL;
- PL_nice_chunk_size = 0;
- }
- else {
- char *chunk; /* must use New here to match call to */
- Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
- sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
- }
+ char *chunk; /* must use New here to match call to */
+ Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
+ sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
uproot_SV(sv);
return sv;
}
: 0
);
sv->sv_debug_inpad = 0;
- sv->sv_debug_cloned = 0;
+ sv->sv_debug_parent = NULL;
sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
sv->sv_debug_serial = PL_sv_serial++;
while (i--)
PL_body_roots[i] = 0;
- Safefree(PL_nice_chunk);
- PL_nice_chunk = NULL;
- PL_nice_chunk_size = 0;
PL_sv_arenaroot = 0;
PL_sv_root = 0;
}
are decremented to point at the unused 'ghost' memory, knowing that
the pointers are used with offsets to the real memory.
- HE, HEK arenas are managed separately, with separate code, but may
- be merge-able later..
-*/
-
-/* get_arena(size): this creates custom-sized arenas
- TBD: export properly for hv.c: S_more_he().
-*/
-void*
-Perl_get_arena(pTHX_ const size_t arena_size, const svtype bodytype)
-{
- dVAR;
- struct arena_desc* adesc;
- 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) {
- struct arena_set *newroot;
- Newxz(newroot, 1, struct arena_set);
- newroot->set_size = ARENAS_PER_SET;
- 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]);
- assert(!adesc->arena);
-
- Newx(adesc->arena, arena_size, char);
- adesc->size = arena_size;
- adesc->utype = bodytype;
- DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
- curr, (void*)adesc->arena, (UV)arena_size));
-
- return adesc->arena;
-}
-
-
-/* return a thing to the free list */
-
-#define del_body(thing, root) \
- STMT_START { \
- void ** const thing_copy = (void **)thing;\
- *thing_copy = *root; \
- *root = (void*)thing_copy; \
- } STMT_END
-
-/*
=head1 SV-Body Allocation
In turn, the new_body_* allocators call S_new_body(), which invokes
new_body_inline macro, which takes a lock, and takes a body off the
-linked list at PL_body_roots[sv_type], calling S_more_bodies() if
+linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
necessary to refresh an empty list. Then the lock is released, and
the body is returned.
-S_more_bodies calls get_arena(), and carves it up into an array of N
+Perl_more_bodies allocates a new arena, and carves it up into an array of N
bodies, which it strings into a linked list. It looks up arena-size
and body-size from the body_details table described below, thus
supporting the multiple body-types.
If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
the (new|del)_X*V macros are mapped directly to malloc/free.
-*/
-
-/*
-
For each sv-type, struct body_details bodies_by_type[] carries
parameters which control these aspects of SV handling:
+ sizeof (((type*)SvANY((const SV *)0))->last_member)
static const struct body_details bodies_by_type[] = {
- { sizeof(HE), 0, 0, SVt_NULL,
- FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
+ /* HEs use this offset for their arena. */
+ { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
/* The bind placeholder pretends to be an RV for now.
Also it's marked as "can't upgrade" to stop anyone using it before it's
SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
/* 8 bytes on most ILP32 with IEEE doubles */
- { sizeof(XPV),
+ { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
+ STRUCT_OFFSET(XPV, xpv_cur),
SVt_PV, FALSE, NONV, HASARENA,
FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
-#if 2 *PTRSIZE <= IVSIZE
/* 12 */
- { sizeof(XPVIV),
+ { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
+ STRUCT_OFFSET(XPV, xpv_cur),
SVt_PVIV, FALSE, NONV, HASARENA,
FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
- /* 12 */
-#else
- { sizeof(XPVIV),
- copy_length(XPVIV, xiv_u),
- 0,
- SVt_PVIV, FALSE, NONV, HASARENA,
- FIT_ARENA(0, sizeof(XPVIV)) },
-#endif
-#if (2 *PTRSIZE <= IVSIZE) && (2 *PTRSIZE <= NVSIZE)
/* 20 */
- { sizeof(XPVNV),
+ { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
+ STRUCT_OFFSET(XPV, xpv_cur),
SVt_PVNV, FALSE, HADNV, HASARENA,
FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
-#else
- /* 20 */
- { sizeof(XPVNV), copy_length(XPVNV, xnv_u), 0, SVt_PVNV, FALSE, HADNV,
- HASARENA, FIT_ARENA(0, sizeof(XPVNV)) },
-#endif
/* 28 */
{ sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
sizeof(regexp),
0,
SVt_REGEXP, FALSE, NONV, HASARENA,
- FIT_ARENA(0, sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur))
+ FIT_ARENA(0, sizeof(regexp))
},
/* 48 */
(void *)((char *)S_new_body(aTHX_ sv_type) \
- bodies_by_type[sv_type].offset)
-#define del_body_allocated(p, sv_type) \
- del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
-
+/* return a thing to the free list */
-#define my_safemalloc(s) (void*)safemalloc(s)
-#define my_safecalloc(s) (void*)safecalloc(s, 1)
-#define my_safefree(p) safefree((char*)p)
+#define del_body(thing, root) \
+ STMT_START { \
+ void ** const thing_copy = (void **)thing; \
+ *thing_copy = *root; \
+ *root = (void*)thing_copy; \
+ } STMT_END
#ifdef PURIFY
-#define new_XNV() my_safemalloc(sizeof(XPVNV))
-#define del_XNV(p) my_safefree(p)
-
-#define new_XPVNV() my_safemalloc(sizeof(XPVNV))
-#define del_XPVNV(p) my_safefree(p)
-
-#define new_XPVAV() my_safemalloc(sizeof(XPVAV))
-#define del_XPVAV(p) my_safefree(p)
-
-#define new_XPVHV() my_safemalloc(sizeof(XPVHV))
-#define del_XPVHV(p) my_safefree(p)
-
-#define new_XPVMG() my_safemalloc(sizeof(XPVMG))
-#define del_XPVMG(p) my_safefree(p)
+#define new_XNV() safemalloc(sizeof(XPVNV))
+#define new_XPVNV() safemalloc(sizeof(XPVNV))
+#define new_XPVMG() safemalloc(sizeof(XPVMG))
-#define new_XPVGV() my_safemalloc(sizeof(XPVGV))
-#define del_XPVGV(p) my_safefree(p)
+#define del_XPVGV(p) safefree(p)
#else /* !PURIFY */
#define new_XNV() new_body_allocated(SVt_NV)
-#define del_XNV(p) del_body_allocated(p, SVt_NV)
-
#define new_XPVNV() new_body_allocated(SVt_PVNV)
-#define del_XPVNV(p) del_body_allocated(p, SVt_PVNV)
-
-#define new_XPVAV() new_body_allocated(SVt_PVAV)
-#define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
-
-#define new_XPVHV() new_body_allocated(SVt_PVHV)
-#define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
-
#define new_XPVMG() new_body_allocated(SVt_PVMG)
-#define del_XPVMG(p) del_body_allocated(p, SVt_PVMG)
-#define new_XPVGV() new_body_allocated(SVt_PVGV)
-#define del_XPVGV(p) del_body_allocated(p, SVt_PVGV)
+#define del_XPVGV(p) del_body(p + bodies_by_type[SVt_PVGV].offset, \
+ &PL_body_roots[SVt_PVGV])
#endif /* PURIFY */
/* no arena for you! */
#define new_NOARENA(details) \
- my_safemalloc((details)->body_size + (details)->offset)
+ safemalloc((details)->body_size + (details)->offset)
#define new_NOARENAZ(details) \
- my_safecalloc((details)->body_size + (details)->offset)
+ safecalloc((details)->body_size + (details)->offset, 1)
-STATIC void *
-S_more_bodies (pTHX_ const svtype sv_type)
+void *
+Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
+ const size_t arena_size)
{
dVAR;
void ** const root = &PL_body_roots[sv_type];
- const struct body_details * const bdp = &bodies_by_type[sv_type];
- const size_t body_size = bdp->body_size;
+ struct arena_desc *adesc;
+ struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
+ unsigned int curr;
char *start;
const char *end;
- const size_t arena_size = Perl_malloc_good_size(bdp->arena_size);
+ const size_t good_arena_size = Perl_malloc_good_size(arena_size);
#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
static bool done_sanity_check;
}
#endif
- assert(bdp->arena_size);
+ assert(arena_size);
- start = (char*) Perl_get_arena(aTHX_ arena_size, sv_type);
+ /* may need new arena-set to hold new arena */
+ 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;
+ PL_body_arenas = (void *) newroot;
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
+ }
- end = start + arena_size - 2 * body_size;
+ /* ok, now have arena-set with at least 1 empty/available arena-desc */
+ curr = aroot->curr++;
+ adesc = &(aroot->set[curr]);
+ assert(!adesc->arena);
+
+ Newx(adesc->arena, good_arena_size, char);
+ adesc->size = good_arena_size;
+ adesc->utype = sv_type;
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
+ curr, (void*)adesc->arena, (UV)good_arena_size));
+
+ start = (char *) adesc->arena;
+
+ /* Get the address of the byte after the end of the last body we can fit.
+ Remember, this is integer division: */
+ end = start + good_arena_size / body_size * body_size;
/* computed count doesnt reflect the 1st slot reservation */
#if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
DEBUG_m(PerlIO_printf(Perl_debug_log,
"arena %p end %p arena-size %d (from %d) type %d "
"size %d ct %d\n",
- (void*)start, (void*)end, (int)arena_size,
- (int)bdp->arena_size, sv_type, (int)body_size,
- (int)arena_size / (int)body_size));
+ (void*)start, (void*)end, (int)good_arena_size,
+ (int)arena_size, sv_type, (int)body_size,
+ (int)good_arena_size / (int)body_size));
#else
DEBUG_m(PerlIO_printf(Perl_debug_log,
"arena %p end %p arena-size %d type %d size %d ct %d\n",
(void*)start, (void*)end,
- (int)bdp->arena_size, sv_type, (int)body_size,
- (int)bdp->arena_size / (int)body_size));
+ (int)arena_size, sv_type, (int)body_size,
+ (int)good_arena_size / (int)body_size));
#endif
*root = (void *)start;
- while (start <= end) {
+ while (1) {
+ /* Where the next body would start: */
char * const next = start + body_size;
+
+ if (next >= end) {
+ /* This is the last body: */
+ assert(next == end);
+
+ *(void **)start = 0;
+ return *root;
+ }
+
*(void**) start = (void *)next;
start = next;
}
- *(void **)start = 0;
-
- return *root;
}
/* grab a new thing from the free list, allocating more if necessary.
STMT_START { \
void ** const r3wt = &PL_body_roots[sv_type]; \
xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
- ? *((void **)(r3wt)) : more_bodies(sv_type)); \
+ ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
+ bodies_by_type[sv_type].body_size,\
+ bodies_by_type[sv_type].arena_size)); \
*(r3wt) = *(void**)(xpv); \
} STMT_END
if (old_type > SVt_IV) {
#ifdef PURIFY
- my_safefree(old_body);
+ safefree(old_body);
#else
/* Note that there is an assumption that all bodies of types that
can be upgraded came from arenas. Only the more complex non-
s = SvPVX_mutable(sv);
if (newlen > SvLEN(sv)) { /* need more room? */
+ STRLEN minlen = SvCUR(sv);
+ minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
+ if (newlen < minlen)
+ newlen = minlen;
#ifndef Perl_safesysmalloc_size
newlen = PERL_STRLEN_ROUNDUP(newlen);
#endif
return sv;
if (SvAMAGIC(sv)) {
SV * const tmpsv = AMG_CALLun(sv,numer);
+ TAINT_IF(tmpsv && SvTAINTED(tmpsv));
if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
return sv_2num(tmpsv);
}
if (flags & SV_SKIP_OVERLOAD)
return NULL;
tmpstr = AMG_CALLun(sv,string);
+ TAINT_IF(tmpstr && SvTAINTED(tmpstr));
if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
/* Unwrap this: */
/* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
sv_force_normal_flags(sv, 0);
}
if (SvREADONLY(sv)) {
- Perl_croak(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
}
(void) sv_utf8_upgrade(sv);
SvUTF8_off(sv);
}
}
else if (IN_PERL_RUNTIME)
- Perl_croak(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
}
#else
if (SvREADONLY(sv)) {
unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
}
else if (IN_PERL_RUNTIME)
- Perl_croak(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
}
#endif
if (SvROK(sv))
&& how != PERL_MAGIC_backref
)
{
- Perl_croak(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
}
}
if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
const MGVTBL* const vtbl = mg->mg_virtual;
*mgp = mg->mg_moremagic;
if (vtbl && vtbl->svt_free)
- CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
+ vtbl->svt_free(aTHX_ sv, mg);
if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
if (mg->mg_len > 0)
Safefree(mg->mg_ptr);
/* Give tsv backref magic if it hasn't already got it, then push a
* back-reference to sv onto the array associated with the backref magic.
+ *
+ * As an optimisation, if there's only one backref and it's not an AV,
+ * store it directly in the HvAUX or mg_obj slot, avoiding the need to
+ * allocate an AV. (Whether the slot holds an AV tells us whether this is
+ * active.)
+ *
+ * If an HV's backref is stored in magic, it is moved back to HvAUX.
*/
/* A discussion about the backreferences array and its refcount:
* structure, from the xhv_backreferences field. (A HV without hv_aux will
* have the standard magic instead.) The array is created with a refcount
* of 2. This means that if during global destruction the array gets
- * picked on first to have its refcount decremented by the random zapper,
- * it won't actually be freed, meaning it's still theere for when its
- * parent gets freed.
- * When the parent SV is freed, in the case of magic, the magic is freed,
- * Perl_magic_killbackrefs is called which decrements one refcount, then
- * mg_obj is freed which kills the second count.
- * In the vase of a HV being freed, one ref is removed by
- * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it
- * calls.
+ * picked on before its parent to have its refcount decremented by the
+ * random zapper, it won't actually be freed, meaning it's still there for
+ * when its parent gets freed.
+ *
+ * When the parent SV is freed, the extra ref is killed by
+ * Perl_sv_kill_backrefs. The other ref is killed, in the case of magic,
+ * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
+ *
+ * When a single backref SV is stored directly, it is not reference
+ * counted.
*/
void
Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
{
dVAR;
- AV *av;
+ SV **svp;
+ AV *av = NULL;
+ MAGIC *mg = NULL;
PERL_ARGS_ASSERT_SV_ADD_BACKREF;
- if (SvTYPE(tsv) == SVt_PVHV) {
- AV **const avp = Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
-
- av = *avp;
- if (!av) {
- /* There is no AV in the offical place - try a fixup. */
- MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
+ /* find slot to store array or singleton backref */
- if (mg) {
- /* Aha. They've got it stowed in magic. Bring it back. */
- av = MUTABLE_AV(mg->mg_obj);
- /* Stop mg_free decreasing the refernce count. */
+ if (SvTYPE(tsv) == SVt_PVHV) {
+ svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
+
+ if (!*svp) {
+ if ((mg = mg_find(tsv, PERL_MAGIC_backref))) {
+ /* Aha. They've got it stowed in magic instead.
+ * Move it back to xhv_backreferences */
+ *svp = mg->mg_obj;
+ /* Stop mg_free decreasing the reference count. */
mg->mg_obj = NULL;
/* Stop mg_free even calling the destructor, given that
there's no AV to free up. */
mg->mg_virtual = 0;
sv_unmagic(tsv, PERL_MAGIC_backref);
- } else {
- av = newAV();
- AvREAL_off(av);
- SvREFCNT_inc_simple_void(av); /* see discussion above */
+ mg = NULL;
}
- *avp = av;
}
} else {
- const MAGIC *const mg
- = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
- if (mg)
- av = MUTABLE_AV(mg->mg_obj);
- else {
- av = newAV();
- AvREAL_off(av);
- sv_magic(tsv, MUTABLE_SV(av), PERL_MAGIC_backref, NULL, 0);
- /* av now has a refcnt of 2; see discussion above */
+ if (! ((mg =
+ (SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL))))
+ {
+ sv_magic(tsv, NULL, PERL_MAGIC_backref, NULL, 0);
+ mg = mg_find(tsv, PERL_MAGIC_backref);
+ }
+ svp = &(mg->mg_obj);
+ }
+
+ /* create or retrieve the array */
+
+ if ( (!*svp && SvTYPE(sv) == SVt_PVAV)
+ || (*svp && SvTYPE(*svp) != SVt_PVAV)
+ ) {
+ /* create array */
+ av = newAV();
+ AvREAL_off(av);
+ SvREFCNT_inc_simple_void(av);
+ /* av now has a refcnt of 2; see discussion above */
+ if (*svp) {
+ /* move single existing backref to the array */
+ av_extend(av, 1);
+ AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
}
+ *svp = (SV*)av;
+ if (mg)
+ mg->mg_flags |= MGf_REFCOUNTED;
+ }
+ else
+ av = MUTABLE_AV(*svp);
+
+ if (!av) {
+ /* optimisation: store single backref directly in HvAUX or mg_obj */
+ *svp = sv;
+ return;
}
+ /* push new backref */
+ assert(SvTYPE(av) == SVt_PVAV);
if (AvFILLp(av) >= AvMAX(av)) {
av_extend(av, AvFILLp(av)+1);
}
* with the SV we point to.
*/
-STATIC void
-S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
+void
+Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
{
dVAR;
- AV *av = NULL;
- SV **svp;
+ SV **svp = NULL;
I32 i;
PERL_ARGS_ASSERT_SV_DEL_BACKREF;
if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
- av = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
- /* We mustn't attempt to "fix up" the hash here by moving the
- backreference array back to the hv_aux structure, as that is stored
- in the main HvARRAY(), and hfreentries assumes that no-one
- reallocates HvARRAY() while it is running. */
+ svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
}
- if (!av) {
- const MAGIC *const mg
+ if (!svp || !*svp) {
+ MAGIC *const mg
= SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
- if (mg)
- av = MUTABLE_AV(mg->mg_obj);
+ svp = mg ? &(mg->mg_obj) : NULL;
}
- if (!av)
+ if (!svp || !*svp)
Perl_croak(aTHX_ "panic: del_backref");
- assert(!SvIS_FREED(av));
-
- svp = AvARRAY(av);
- /* We shouldn't be in here more than once, but for paranoia reasons lets
- not assume this. */
- for (i = AvFILLp(av); i >= 0; i--) {
- if (svp[i] == sv) {
- const SSize_t fill = AvFILLp(av);
- if (i != fill) {
- /* We weren't the last entry.
- An unordered list has this property that you can take the
- last element off the end to fill the hole, and it's still
- an unordered list :-)
- */
- svp[i] = svp[fill];
+ if (SvTYPE(*svp) == SVt_PVAV) {
+ int count = 0;
+ AV * const av = (AV*)*svp;
+ assert(!SvIS_FREED(av));
+ svp = AvARRAY(av);
+ for (i = AvFILLp(av); i >= 0; i--) {
+ if (svp[i] == sv) {
+ const SSize_t fill = AvFILLp(av);
+ if (i != fill) {
+ /* We weren't the last entry.
+ An unordered list has this property that you can take the
+ last element off the end to fill the hole, and it's still
+ an unordered list :-)
+ */
+ svp[i] = svp[fill];
+ }
+ svp[fill] = NULL;
+ AvFILLp(av) = fill - 1;
+ count++;
+#ifndef DEBUGGING
+ break; /* should only be one */
+#endif
}
- svp[fill] = NULL;
- AvFILLp(av) = fill - 1;
}
+ assert(count == 1);
}
+ else {
+ /* optimisation: only a single backref, stored directly */
+ if (*svp != sv)
+ Perl_croak(aTHX_ "panic: del_backref");
+ *svp = NULL;
+ }
+
}
-int
+void
Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
{
- SV **svp = AvARRAY(av);
+ SV **svp;
+ SV **last;
+ bool is_array;
PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
- PERL_UNUSED_ARG(sv);
- assert(!svp || !SvIS_FREED(av));
- if (svp) {
- SV *const *const last = svp + AvFILLp(av);
+ if (!av)
+ return;
+ is_array = (SvTYPE(av) == SVt_PVAV);
+ if (is_array) {
+ assert(!SvIS_FREED(av));
+ svp = AvARRAY(av);
+ if (svp)
+ last = svp + AvFILLp(av);
+ }
+ else {
+ /* optimisation: only a single backref, stored directly */
+ svp = (SV**)&av;
+ last = svp;
+ }
+
+ if (svp) {
while (svp <= last) {
if (*svp) {
SV *const referrer = *svp;
if (SvWEAKREF(referrer)) {
/* XXX Should we check that it hasn't changed? */
+ assert(SvROK(referrer));
SvRV_set(referrer, 0);
SvOK_off(referrer);
SvWEAKREF_off(referrer);
SvSETMAGIC(referrer);
} else if (SvTYPE(referrer) == SVt_PVGV ||
SvTYPE(referrer) == SVt_PVLV) {
+ assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
/* You lookin' at me? */
assert(GvSTASH(referrer));
assert(GvSTASH(referrer) == (const HV *)sv);
GvSTASH(referrer) = 0;
+ } else if (SvTYPE(referrer) == SVt_PVCV ||
+ SvTYPE(referrer) == SVt_PVFM) {
+ if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
+ /* You lookin' at me? */
+ assert(CvSTASH(referrer));
+ assert(CvSTASH(referrer) == (const HV *)sv);
+ CvSTASH(referrer) = 0;
+ }
+ else {
+ assert(SvTYPE(sv) == SVt_PVGV);
+ /* You lookin' at me? */
+ assert(CvGV(referrer));
+ assert(CvGV(referrer) == (const GV *)sv);
+ anonymise_cv_maybe(MUTABLE_GV(sv),
+ MUTABLE_CV(referrer));
+ }
+
} else {
Perl_croak(aTHX_
"panic: magic_killbackrefs (flags=%"UVxf")",
(UV)SvFLAGS(referrer));
}
- *svp = NULL;
+ if (is_array)
+ *svp = NULL;
}
svp++;
}
}
- SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
- return 0;
+ if (is_array) {
+ AvFILLp(av) = -1;
+ SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
+ }
+ return;
}
/*
del_SV(nsv);
}
+/* We're about to free a GV which has a CV that refers back to us.
+ * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
+ * field) */
+
+STATIC void
+S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
+{
+ char *stash;
+ SV *gvname;
+ GV *anongv;
+
+ PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
+
+ /* be assertive! */
+ assert(SvREFCNT(gv) == 0);
+ assert(isGV(gv) && isGV_with_GP(gv));
+ assert(GvGP(gv));
+ assert(!CvANON(cv));
+ assert(CvGV(cv) == gv);
+
+ /* will the CV shortly be freed by gp_free() ? */
+ if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
+ SvANY(cv)->xcv_gv = NULL;
+ return;
+ }
+
+ /* if not, anonymise: */
+ stash = GvSTASH(gv) ? HvNAME(GvSTASH(gv)) : NULL;
+ gvname = Perl_newSVpvf(aTHX_ "%s::__ANON__",
+ stash ? stash : "__ANON__");
+ anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
+ SvREFCNT_dec(gvname);
+
+ CvANON_on(cv);
+ CvCVGV_RC_on(cv);
+ SvANY(cv)->xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
+}
+
+
/*
=for apidoc sv_clear
if (IoIFP(sv) &&
IoIFP(sv) != PerlIO_stdin() &&
IoIFP(sv) != PerlIO_stdout() &&
- IoIFP(sv) != PerlIO_stderr())
+ IoIFP(sv) != PerlIO_stderr() &&
+ !(IoFLAGS(sv) & IOf_FAKE_DIRP))
{
io_close(MUTABLE_IO(sv), FALSE);
}
case SVt_PVCV:
case SVt_PVFM:
cv_undef(MUTABLE_CV(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 ((stash = CvSTASH(sv)))
+ sv_del_backref(MUTABLE_SV(stash), sv);
goto freescalar;
case SVt_PVHV:
if (PL_last_swash_hv == (const HV *)sv) {
}
}
#ifdef PERL_OLD_COPY_ON_WRITE
- else if (SvPVX_const(sv)) {
+ else if (SvPVX_const(sv)
+ && !(SvTYPE(sv) == SVt_PVIO && !(IoFLAGS(sv) & IOf_FAKE_DIRP))) {
if (SvIsCOW(sv)) {
if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
}
}
#else
- else if (SvPVX_const(sv) && SvLEN(sv))
+ else if (SvPVX_const(sv) && SvLEN(sv)
+ && !(SvTYPE(sv) == SVt_PVIO && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
Safefree(SvPVX_mutable(sv));
else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
&PL_body_roots[type]);
}
else if (sv_type_details->body_size) {
- my_safefree(SvANY(sv));
+ safefree(SvANY(sv));
}
}
STRLEN ulen;
MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
- if (mg && mg->mg_len != -1) {
- ulen = mg->mg_len;
+ if (mg && (mg->mg_len != -1 || mg->mg_ptr)) {
+ if (mg->mg_len != -1)
+ ulen = mg->mg_len;
+ else {
+ /* We can use the offset cache for a headstart.
+ The longer value is stored in the first pair. */
+ STRLEN *cache = (STRLEN *) mg->mg_ptr;
+
+ ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1],
+ s + len);
+ }
+
if (PL_utf8cache < 0) {
const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
- if (real != ulen) {
- /* Need to turn the assertions off otherwise we may
- recurse infinitely while printing error messages.
- */
- SAVEI8(PL_utf8cache);
- PL_utf8cache = 0;
- Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf
- " real %"UVuf" for %"SVf,
- (UV) ulen, (UV) real, SVfARG(sv));
- }
+ assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv);
}
}
else {
ulen = Perl_utf8_length(aTHX_ s, s + len);
- if (!SvREADONLY(sv)) {
- if (!mg && (SvTYPE(sv) < SVt_PVMG ||
- !(mg = mg_find(sv, PERL_MAGIC_utf8)))) {
- mg = sv_magicext(sv, 0, PERL_MAGIC_utf8,
- &PL_vtbl_utf8, 0, 0);
- }
- assert(mg);
- mg->mg_len = ulen;
- /* For now, treat "overflowed" as "still unknown".
- See RT #72924. */
- if (ulen != (STRLEN) mg->mg_len)
- mg->mg_len = -1;
- }
+ utf8_mg_len_cache_update(sv, &mg, ulen);
}
return ulen;
}
offset. */
static STRLEN
S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
- STRLEN uoffset)
+ STRLEN *const uoffset_p, bool *const at_end)
{
const U8 *s = start;
+ STRLEN uoffset = *uoffset_p;
PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
- while (s < send && uoffset--)
+ while (s < send && uoffset) {
+ --uoffset;
s += UTF8SKIP(s);
- if (s > send) {
+ }
+ if (s == send) {
+ *at_end = TRUE;
+ }
+ else if (s > send) {
+ *at_end = TRUE;
/* This is the existing behaviour. Possibly it should be a croak, as
it's actually a bounds error */
s = send;
}
+ *uoffset_p -= uoffset;
return s - start;
}
the passed in UTF-8 offset. */
static STRLEN
S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
- const STRLEN uoffset, const STRLEN uend)
+ STRLEN uoffset, const STRLEN uend)
{
STRLEN backw = uend - uoffset;
/* The assumption is that going forwards is twice the speed of going
forward (that's where the 2 * backw comes from).
(The real figure of course depends on the UTF-8 data.) */
- return sv_pos_u2b_forwards(start, send, uoffset);
+ const U8 *s = start;
+
+ while (s < send && uoffset--)
+ s += UTF8SKIP(s);
+ assert (s <= send);
+ if (s > send)
+ s = send;
+ return s - start;
}
while (backw--) {
created if necessary, and the found value offered to it for update. */
static STRLEN
S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
- const U8 *const send, const STRLEN uoffset,
+ const U8 *const send, STRLEN uoffset,
STRLEN uoffset0, STRLEN boffset0)
{
STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
bool found = FALSE;
+ bool at_end = FALSE;
PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
assert (uoffset >= uoffset0);
+ if (!uoffset)
+ return 0;
+
if (!SvREADONLY(sv)
&& PL_utf8cache
&& (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
uoffset - uoffset0,
(*mgp)->mg_len - uoffset0);
} else {
+ uoffset -= uoffset0;
boffset = boffset0
+ sv_pos_u2b_forwards(start + boffset0,
- send, uoffset - uoffset0);
+ send, &uoffset, &at_end);
+ uoffset += uoffset0;
}
}
else if (cache[2] < uoffset) {
}
if (!found || PL_utf8cache < 0) {
- const STRLEN real_boffset
- = boffset0 + sv_pos_u2b_forwards(start + boffset0,
- send, uoffset - uoffset0);
-
- if (found && PL_utf8cache < 0) {
- if (real_boffset != boffset) {
- /* Need to turn the assertions off otherwise we may recurse
- infinitely while printing error messages. */
- SAVEI8(PL_utf8cache);
- PL_utf8cache = 0;
- Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf
- " real %"UVuf" for %"SVf,
- (UV) boffset, (UV) real_boffset, SVfARG(sv));
- }
- }
+ STRLEN real_boffset;
+ uoffset -= uoffset0;
+ real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0,
+ send, &uoffset, &at_end);
+ uoffset += uoffset0;
+
+ if (found && PL_utf8cache < 0)
+ assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset,
+ real_boffset, sv);
boffset = real_boffset;
}
- if (PL_utf8cache)
- utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
+ if (PL_utf8cache) {
+ if (at_end)
+ utf8_mg_len_cache_update(sv, mgp, uoffset);
+ else
+ utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
+ }
return boffset;
}
MAGIC *mg = NULL;
boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
- if (lenp) {
+ if (lenp
+ && *lenp /* don't bother doing work for 0, as its bytes equivalent
+ is 0, and *lenp is already set to that. */) {
/* Convert the relative offset to absolute. */
const STRLEN uoffset2 = uoffset + *lenp;
const STRLEN boffset2
}
}
+static void
+S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp,
+ const STRLEN ulen)
+{
+ PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
+ if (SvREADONLY(sv))
+ return;
+
+ if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
+ !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
+ *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
+ }
+ assert(*mgp);
+
+ (*mgp)->mg_len = ulen;
+ /* For now, treat "overflowed" as "still unknown". See RT #72924. */
+ if (ulen != (STRLEN) (*mgp)->mg_len)
+ (*mgp)->mg_len = -1;
+}
+
/* Create and update the UTF8 magic offset cache, with the proffered utf8/
byte length pairing. The (byte) length of the total SV is passed in too,
as blen, because for some (more esoteric) SVs, the call to SvPV_const()
const U8 *start = (const U8 *) SvPVX_const(sv);
const STRLEN realutf8 = utf8_length(start, start + byte);
- if (realutf8 != utf8) {
- /* Need to turn the assertions off otherwise we may recurse
- infinitely while printing error messages. */
- SAVEI8(PL_utf8cache);
- PL_utf8cache = 0;
- Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf
- " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv));
- }
+ assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8,
+ sv);
}
/* Cache is held with the later position first, to simplify the code
if (!found || PL_utf8cache < 0) {
const STRLEN real_len = utf8_length(s, send);
- if (found && PL_utf8cache < 0) {
- if (len != real_len) {
- /* Need to turn the assertions off otherwise we may recurse
- infinitely while printing error messages. */
- SAVEI8(PL_utf8cache);
- PL_utf8cache = 0;
- Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf
- " real %"UVuf" for %"SVf,
- (UV) len, (UV) real_len, SVfARG(sv));
- }
- }
+ if (found && PL_utf8cache < 0)
+ assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv);
len = real_len;
}
*offsetp = len;
- if (PL_utf8cache)
- utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
+ if (PL_utf8cache) {
+ if (blen == byte)
+ utf8_mg_len_cache_update(sv, &mg, len);
+ else
+ utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
+ }
+}
+
+static void
+S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache,
+ STRLEN real, SV *const sv)
+{
+ PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT;
+
+ /* As this is debugging only code, save space by keeping this test here,
+ rather than inlining it in all the callers. */
+ if (from_cache == real)
+ return;
+
+ /* Need to turn the assertions off otherwise we may recurse infinitely
+ while printing error messages. */
+ SAVEI8(PL_utf8cache);
+ PL_utf8cache = 0;
+ Perl_croak(aTHX_ "panic: %s cache %"UVuf" real %"UVuf" for %"SVf,
+ func, (UV) from_cache, (UV) real, SVfARG(sv));
}
/*
}
SvPOK_only(sv);
+ if (!append) {
+ SvCUR_set(sv,0);
+ }
if (PerlIO_isutf8(fp))
SvUTF8_on(sv);
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
if (IN_PERL_RUNTIME)
- Perl_croak(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
}
if (SvROK(sv)) {
IV i;
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
if (IN_PERL_RUNTIME)
- Perl_croak(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
}
if (SvROK(sv)) {
IV i;
}
/*
-=for apidoc sv_reftype
+=for apidoc sv_reftype_len
+
+Returns a string describing what type of item the SV is a reference to,
+storing the length of the string in *ret_len.
+
+If 'ob' is true and the item is an "object" returns the class name
+instead of the underlying type.
+
+Possible return values are:
+
+=over 4
+
+=item VSTRING
+
+Has special v-string magic
+
+=item REF
+
+Is a reference to another ref (C<< $$ref >>)
+
+=item SCALAR
+
+Is a reference to a scalar (C<< $$scalar >>)
+
+=item LVALUE
+
+An lvalue reference - B<NOTE>, tied lvalues appear to be of type C<SCALAR>
+for backwards compatibility reasons
+
+=item ARRAY
+
+An array reference (C<< @$array >>)
-Returns a string describing what the SV is a reference to.
+=item HASH
+
+A hash reference (C<< %$hash >>)
+
+=item CODE
+
+A subroutine reference (C<< $code->() >>)
+
+=item GLOB
+
+A reference to a glob (C<< *$glob >>)
+
+=item FORMAT
+
+A format reference (C<< *IO{FORMAT} >>)
+
+=item IO
+
+An IO reference (C<< *STDOUT{IO} >>)
+
+=item BIND
+
+A bind reference
+
+=item REGEXP
+
+An executable regular expression (C<< qr/../ >>)
+
+=item UNKNOWN
+
+This should never be seen
+
+=back
=cut
*/
+
const char *
-Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
+Perl_sv_reftype_len(pTHX_ const SV *const sv, const int ob, STRLEN *const ret_len)
{
- PERL_ARGS_ASSERT_SV_REFTYPE;
+ PERL_ARGS_ASSERT_SV_REFTYPE_LEN;
+ assert(ret_len!=NULL);
- /* The fact that I don't need to downcast to char * everywhere, only in ?:
+ /* The fact that I don't need to downcast to char * everywhere, only in ?: (not used anymore)
inside return suggests a const propagation bug in g++. */
+
+ /*
+ * NOTE:
+ *
+ * This code is formatted so that the following command spits out a POD list of the
+ * legal "reftypes" which is included above as well as in the lib/mauve.pm
+
+ perl -MText::Wrap -le'local $/; $_= <>; while ( m!SV_REFTYPE_RETURN\("(\w+)"\);\s*[/][*]\s*(.*?)\s*[*][/]!gs) {
+ $i=$1; ($t=$2)=~s/\s+/ /g; $o.=wrap("\n\n=item $i\n\n","",$t);} print "=over 4\n$o\n\n=back\n"' sv.c
+
+ *
+ * If you update this code please use the above to update the pod.
+ *
+ */
+ /* we use this to make it cleaner to return the size and length at the same time,
+ * and we use two aliases so we can use the above perl snippet to turn it into documentation
+ * the ("" s "") trick guarantees we getting a string passed in (see perl.h for similar stuff)
+ */
+#define SV_REFTYPE_RETURN(s) STMT_START { *ret_len= sizeof(s)-1; return ("" s ""); } STMT_END
+#define SV_BLESSED_RETURN(s) SV_REFTYPE_RETURN(s)
+
if (ob && SvOBJECT(sv)) {
char * const name = HvNAME_get(SvSTASH(sv));
- return name ? name : (char *) "__ANON__";
+ if (name) {
+ *ret_len = HvNAMELEN_get(SvSTASH(sv));
+ return name;
+ } else SV_BLESSED_RETURN("__ANON__"); /* I don't see when this could happen - demerphq */
}
else {
switch (SvTYPE(sv)) {
case SVt_PVNV:
case SVt_PVMG:
if (SvVOK(sv))
- return "VSTRING";
+ SV_REFTYPE_RETURN("VSTRING"); /* Has special v-string magic */
if (SvROK(sv))
- return "REF";
+ SV_REFTYPE_RETURN("REF"); /* Is a reference to another ref (C<< $$ref >>) */
else
- return "SCALAR";
+ SV_REFTYPE_RETURN("SCALAR"); /* Is a reference to a scalar (C<< $$scalar >>) */
- case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
- /* tied lvalues should appear to be
- * scalars for backwards compatitbility */
- : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
- ? "SCALAR" : "LVALUE");
- case SVt_PVAV: return "ARRAY";
- case SVt_PVHV: return "HASH";
- case SVt_PVCV: return "CODE";
- case SVt_PVGV: return (char *) (isGV_with_GP(sv)
- ? "GLOB" : "SCALAR");
- case SVt_PVFM: return "FORMAT";
- case SVt_PVIO: return "IO";
- case SVt_BIND: return "BIND";
- case SVt_REGEXP: return "REGEXP";
- default: return "UNKNOWN";
+ case SVt_PVLV: if (SvROK(sv))
+ SV_REFTYPE_RETURN("REF");
+ else if (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
+ /* tied lvalues appear to be scalars for back-compat reasons */
+ SV_REFTYPE_RETURN("SCALAR");
+ else
+ SV_REFTYPE_RETURN("LVALUE"); /* An lvalue reference - B<NOTE>, tied lvalues
+ appear to be of type C<SCALAR> for backwards
+ compatibility reasons */
+
+ case SVt_PVAV: SV_REFTYPE_RETURN("ARRAY"); /* An array reference (C<< @$array >>) */
+ case SVt_PVHV: SV_REFTYPE_RETURN("HASH"); /* A hash reference (C<< %$hash >>) */
+ case SVt_PVCV: SV_REFTYPE_RETURN("CODE"); /* A subroutine reference (C<< $code->() >>) */
+ case SVt_PVGV: if(isGV_with_GP(sv))
+ SV_REFTYPE_RETURN("GLOB"); /* A reference to a glob (C<< *$glob >>) */
+ else
+ SV_REFTYPE_RETURN("SCALAR");
+ case SVt_PVFM: SV_REFTYPE_RETURN("FORMAT"); /* A format reference (C<< *IO{FORMAT} >>) */
+ case SVt_PVIO: SV_REFTYPE_RETURN("IO"); /* An IO reference (C<< *STDOUT{IO} >>) */
+ case SVt_BIND: SV_REFTYPE_RETURN("BIND"); /* A bind reference */
+ case SVt_REGEXP: SV_REFTYPE_RETURN("REGEXP"); /* An executable regular expression (C<< qr/../ >>) */
+ default: SV_REFTYPE_RETURN("UNKNOWN"); /* This should never be seen */
}
}
+#undef SV_BLESSED_RETURN
+#undef SV_REFTYPE_RETURN
+
+}
+
+/*
+=for apidoc sv_reftype
+
+Returns a string describing what type of item the SV is a reference to.
+
+If 'ob' is true and the item is an "object" returns the class name
+instead of the underlying type. Note in this form this routine is not
+recommended as you have no way to know the correct length of the class,
+and null is legal in a class name. Use Perl_sv_reftype_len instead.
+
+=cut
+*/
+
+const char *
+Perl_sv_reftype(pTHX_ const SV *const sv, const int ob){
+ STRLEN len;
+ PERL_ARGS_ASSERT_SV_REFTYPE;
+ return sv_reftype_len(sv,ob,&len);
}
/*
if (SvIsCOW(tmpRef))
sv_force_normal_flags(tmpRef, 0);
if (SvREADONLY(tmpRef))
- Perl_croak(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
if (SvOBJECT(tmpRef)) {
if (SvTYPE(tmpRef) != SVt_PVIO)
--PL_sv_objcount;
Newxz(parser, 1, yy_parser);
ptr_table_store(PL_ptr_table, proto, parser);
- parser->yyerrstatus = 0;
- parser->yychar = YYEMPTY; /* Cause a token to be read. */
-
/* XXX these not yet duped */
parser->old_parser = NULL;
parser->stack = NULL;
for (; mg; mg = mg->mg_moremagic) {
MAGIC *nmg;
+
+ if ((param->flags & CLONEf_JOIN_IN)
+ && mg->mg_type == PERL_MAGIC_backref)
+ /* when joining, we let the individual SVs add themselves to
+ * backref as needed. */
+ continue;
+
Newx(nmg, 1, MAGIC);
*mgprev_p = nmg;
mgprev_p = &(nmg->mg_moremagic);
}
else
*/
- if(nmg->mg_type == PERL_MAGIC_backref) {
- /* The backref AV has its reference count deliberately bumped by
- 1. */
- nmg->mg_obj
- = SvREFCNT_inc(av_dup_inc((const AV *) nmg->mg_obj, param));
- }
- else {
- nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
- ? sv_dup_inc(nmg->mg_obj, param)
- : sv_dup(nmg->mg_obj, param);
- }
+ nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
+ ? nmg->mg_type == PERL_MAGIC_backref
+ /* The backref AV has its reference
+ * count deliberately bumped by 1 */
+ ? SvREFCNT_inc(av_dup_inc((const AV *)
+ nmg->mg_obj, param))
+ : sv_dup_inc(nmg->mg_obj, param)
+ : sv_dup(nmg->mg_obj, param);
if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
if (nmg->mg_len > 0) {
nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
}
if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
- CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
+ nmg->mg_virtual->svt_dup(aTHX_ nmg, param);
}
}
return mgret;
tbl->tbl_max = --newsize;
tbl->tbl_ary = ary;
for (i=0; i < oldsize; i++, ary++) {
- PTR_TBL_ENT_t **curentp, **entp, *ent;
- if (!*ary)
+ PTR_TBL_ENT_t **entp = ary;
+ PTR_TBL_ENT_t *ent = *ary;
+ PTR_TBL_ENT_t **curentp;
+ if (!ent)
continue;
curentp = ary + oldsize;
- for (entp = ary, ent = *ary; ent; ent = *entp) {
+ do {
if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
*entp = ent->next;
ent->next = *curentp;
*curentp = ent;
- continue;
}
else
entp = &ent->next;
- }
+ ent = *entp;
+ } while (ent);
}
}
PERL_ARGS_ASSERT_RVPV_DUP;
if (SvROK(sstr)) {
- SvRV_set(dstr, SvWEAKREF(sstr)
- ? sv_dup(SvRV_const(sstr), param)
- : sv_dup_inc(SvRV_const(sstr), param));
-
+ if (SvWEAKREF(sstr)) {
+ SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
+ if (param->flags & CLONEf_JOIN_IN) {
+ /* if joining, we add any back references individually rather
+ * than copying the whole backref array */
+ Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr);
+ }
+ }
+ else
+ SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));
}
else if (SvPVX_const(sstr)) {
/* Has something there */
something that is bad **/
if (SvTYPE(sstr) == SVt_PVHV) {
const HEK * const hvname = HvNAME_HEK(sstr);
- if (hvname)
+ if (hvname) {
/** don't clone stashes if they already exist **/
- return MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
+ dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
+ ptr_table_store(PL_ptr_table, sstr, dstr);
+ return dstr;
+ }
}
}
dstr->sv_debug_optype = sstr->sv_debug_optype;
dstr->sv_debug_line = sstr->sv_debug_line;
dstr->sv_debug_inpad = sstr->sv_debug_inpad;
- dstr->sv_debug_cloned = 1;
+ dstr->sv_debug_parent = (SV*)sstr;
dstr->sv_debug_file = savepv(sstr->sv_debug_file);
#endif
#endif
if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
- && !isGV_with_GP(dstr))
+ && !isGV_with_GP(dstr)
+ && !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
/* The Copy above means that all the source (unduplicated) pointers
else
LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
case SVt_PVGV:
+ /* non-GP case already handled above */
if(isGV_with_GP(sstr)) {
GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
/* Don't call sv_add_backref here as it's going to be
/* Danger Will Robinson - GvGP(dstr) isn't initialised
at the point of this comment. */
GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
- if(param->flags & CLONEf_JOIN_IN) {
- const HEK * const hvname
- = HvNAME_HEK(GvSTASH(dstr));
- if( hvname
- && GvSTASH(dstr) == gv_stashpvn(
- HEK_KEY(hvname), HEK_LEN(hvname), 0
- )
- )
- Perl_sv_add_backref(
- aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr
- );
- }
+ if (param->flags & CLONEf_JOIN_IN)
+ Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
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);
- if (IoOFP(dstr) == IoIFP(sstr))
- IoOFP(dstr) = IoIFP(dstr);
- else
- IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
/* PL_parser->rsfp_filters entries have fake IoDIRP() */
if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
/* I have no idea why fake dirp (rsfps)
NOOP;
/* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
}
+ IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(dstr), param);
}
+ if (IoOFP(dstr) == IoIFP(sstr))
+ IoOFP(dstr) = IoIFP(dstr);
+ else
+ IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
cBOOL(HvSHAREKEYS(sstr)), param) : 0;
/* backref array needs refcnt=2; see sv_add_backref */
daux->xhv_backreferences =
- saux->xhv_backreferences
- ? MUTABLE_AV(SvREFCNT_inc(
- sv_dup_inc((const SV *)saux->xhv_backreferences, param)))
+ (param->flags & CLONEf_JOIN_IN)
+ /* when joining, we let the individual GVs and
+ * CVs add themselves to backref as
+ * needed. This avoids pulling in stuff
+ * that isn't required, and simplifies the
+ * case where stashes aren't cloned back
+ * if they already exist in the parent
+ * thread */
+ ? NULL
+ : saux->xhv_backreferences
+ ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV)
+ ? MUTABLE_AV(SvREFCNT_inc(
+ sv_dup_inc((const SV *)
+ saux->xhv_backreferences, param)))
+ : MUTABLE_AV(sv_dup((const SV *)
+ saux->xhv_backreferences, param))
: 0;
daux->xhv_mro_meta = saux->xhv_mro_meta
if (!(param->flags & CLONEf_COPY_STACKS)) {
CvDEPTH(dstr) = 0;
}
+ /*FALLTHROUGH*/
case SVt_PVFM:
/* NOTE: not refcounted */
CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
+ if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
+ Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
OP_REFCNT_LOCK;
if (!CvISXSUB(dstr))
CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
}
/* don't dup if copying back - CvGV isn't refcounted, so the
* duped GV may never be freed. A bit of a hack! DAPM */
- CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
- NULL : gv_dup(CvGV(dstr), param) ;
- PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
+ SvANY(MUTABLE_CV(dstr))->xcv_gv =
+ CvCVGV_RC(dstr)
+ ? gv_dup_inc(CvGV(sstr), param)
+ : (param->flags & CLONEf_JOIN_IN)
+ ? NULL
+ : gv_dup(CvGV(sstr), param);
+
+ CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
CvOUTSIDE(dstr) =
CvWEAKOUTSIDE(sstr)
? cv_dup( CvOUTSIDE(dstr), param)
SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL;
PERL_ARGS_ASSERT_SV_DUP;
- /* Track every SV that (at least initially) had a reference count of 0. */
+ /* Track every SV that (at least initially) had a reference count of 0.
+ We need to do this by holding an actual reference to it in this array.
+ If we attempt to cheat, turn AvREAL_off(), and store only pointers
+ (akin to the stashes hash, and the perl stack), we come unstuck if
+ a weak reference (or other SV legitimately SvREFCNT() == 0 for this
+ thread) is manipulated in a CLONE method, because CLONE runs before the
+ unreferenced array is walked to find SVs still with SvREFCNT() == 0
+ (and fix things up by giving each a reference via the temps stack).
+ Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and
+ then SvREFCNT_dec(), it will be cleaned up (and added to the free list)
+ before the walk of unreferenced happens and a reference to that is SV
+ added to the temps stack. At which point we have the same SV considered
+ to be in use, and free to be re-used. Not good.
+ */
if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) {
assert(param->unreferenced);
- av_push(param->unreferenced, dstr);
+ av_push(param->unreferenced, SvREFCNT_inc(dstr));
}
return dstr;
case CXt_LOOP_LAZYIV:
case CXt_LOOP_PLAIN:
if (CxPADLOOP(ncx)) {
- ncx->blk_loop.oldcomppad
+ ncx->blk_loop.itervar_u.oldcomppad
= (PAD*)ptr_table_fetch(PL_ptr_table,
- ncx->blk_loop.oldcomppad);
+ ncx->blk_loop.itervar_u.oldcomppad);
} else {
- ncx->blk_loop.oldcomppad
- = (PAD*)gv_dup((const GV *)ncx->blk_loop.oldcomppad,
- param);
+ ncx->blk_loop.itervar_u.gv
+ = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv,
+ param);
}
break;
case CXt_FORMAT:
PL_parser = NULL;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
# ifdef DEBUG_LEAKING_SCALARS
- PL_sv_serial = (((U32)my_perl >> 2) & 0xfff) * 1000000;
+ PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
# endif
#else /* !DEBUGGING */
Zero(my_perl, 1, PerlInterpreter);
PL_body_arenas = NULL;
Zero(&PL_body_roots, 1, PL_body_roots);
- PL_nice_chunk = NULL;
- PL_nice_chunk_size = 0;
PL_sv_count = 0;
PL_sv_objcount = 0;
PL_sv_root = NULL;
if (!(flags & CLONEf_COPY_STACKS)) {
param->unreferenced = newAV();
- AvREAL_off(param->unreferenced);
}
/* Set tainting stuff before PerlIO_debug can possibly get called */
/* switches */
PL_minus_c = proto_perl->Iminus_c;
PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
+ PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param);
PL_localpatches = proto_perl->Ilocalpatches;
PL_splitstr = proto_perl->Isplitstr;
PL_minus_n = proto_perl->Iminus_n;
PL_unlockhook = proto_perl->Iunlockhook;
PL_threadhook = proto_perl->Ithreadhook;
PL_destroyhook = proto_perl->Idestroyhook;
+ PL_signalhook = proto_perl->Isignalhook;
#ifdef THREADS_HAVE_PIDS
PL_ppid = proto_perl->Ippid;
/* Pluggable optimizer */
PL_peepp = proto_perl->Ipeepp;
+ PL_rpeepp = proto_perl->Irpeepp;
/* op_free() hook */
PL_opfreehook = proto_perl->Iopfreehook;
}
PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
+ PL_blockhooks = av_dup_inc(proto_perl->Iblockhooks, param);
/* Call the ->CLONE method, if it exists, for each of the stashes
identified by sv_dup() above.
SSize_t count = 0;
do {
- if (!SvREFCNT(*svp))
+ if (SvREFCNT(*svp) == 1)
++count;
} while (++svp <= last);
svp = AvARRAY(unreferenced);
do {
- if (!SvREFCNT(*svp))
- PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(*svp);
+ if (SvREFCNT(*svp) == 1) {
+ /* Our reference is the only one to this SV. This means that
+ in this thread, the scalar effectively has a 0 reference.
+ That doesn't work (cleanup never happens), so donate our
+ reference to it onto the save stack. */
+ PL_tmps_stack[++PL_tmps_ix] = *svp;
+ } else {
+ /* As an optimisation, because we are already walking the
+ entire array, instead of above doing either
+ SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead
+ release our reference to the scalar, so that at the end of
+ the array owns zero references to the scalars it happens to
+ point to. We are effectively converting the array from
+ AvREAL() on to AvREAL() off. This saves the av_clear()
+ (triggered by the SvREFCNT_dec(unreferenced) below) from
+ walking the array a second time. */
+ SvREFCNT_dec(*svp);
+ }
+
} while (++svp <= last);
+ AvREAL_off(unreferenced);
}
SvREFCNT_dec(unreferenced);
}
void
Perl_clone_params_del(CLONE_PARAMS *param)
{
- PerlInterpreter *const was = PERL_GET_THX;
+ /* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT
+ happy: */
PerlInterpreter *const to = param->new_perl;
dTHXa(to);
+ PerlInterpreter *const was = PERL_GET_THX;
PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
CLONE_PARAMS *
Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
{
+ dVAR;
/* Need to play this game, as newAV() can call safesysmalloc(), and that
does a dTHX; to get the context from thread local storage.
FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
AvREAL_off(param->stashes);
param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
- AvREAL_off(param->unreferenced);
if (was != to) {
PERL_SET_THX(was);
https://perl5.git.perl.org / perl5.git / blobdiff