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
dVAR;
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
SvFLAGS(sv) |= SVf_BREAK;
- if (PL_comppad == (AV*)sv) {
- PL_comppad = NULL;
- PL_curpad = NULL;
- }
SvREFCNT_dec(sv);
}
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));
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
+ curr, (void*)adesc->arena, (UV)arena_size));
return adesc->arena;
}
#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),
#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.
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);
hv_undef((HV*)sv);
break;
case SVt_PVAV:
+ if (PL_comppad == (AV*)sv) {
+ PL_comppad = NULL;
+ PL_curpad = NULL;
+ }
av_undef((AV*)sv);
break;
case SVt_PVLV:
if (!SvVALID(sv) && GvSTASH(sv))
sv_del_backref((SV*)GvSTASH(sv), sv);
}
+ /* FIXME. There are probably more unreferenced pointers to SVs in the
+ interpreter struct that we should check and tidy in a similar
+ fashion to this: */
+ if ((GV*)sv == PL_last_in_gv)
+ PL_last_in_gv = NULL;
case SVt_PVMG:
case SVt_PVNV:
case SVt_PVIV:
pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
Perl_dump_sv_child(aTHX_ sv);
+#else
+ #ifdef DEBUG_LEAKING_SCALARS
+ sv_dump(sv);
+ #endif
#endif
}
return;
}
/*
+=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);
if (!*s) { /* reset ?? searches */
MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
if (mg) {
- PMOP *pm = (PMOP *) mg->mg_obj;
- while (pm) {
- pm->op_pmdynflags &= ~PMdf_USED;
- pm = pm->op_pmnext;
+ const U32 count = mg->mg_len / sizeof(PMOP**);
+ PMOP **pmp = (PMOP**) mg->mg_ptr;
+ PMOP *const *const end = pmp + count;
+
+ while (pmp < end) {
+#ifdef USE_ITHREADS
+ SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
+#else
+ (*pmp)->op_pmflags &= ~PMf_USED;
+#endif
+ ++pmp;
}
}
return;
goto unknown;
}
vecsv = sv_newmortal();
- /* scan_vstring is expected to be called during
- * tokenization, so we need to fake up the end
- * of the buffer for it
- */
- PL_bufend = version + veclen;
- scan_vstring(version, vecsv);
+ scan_vstring(version, version + veclen, vecsv);
vecstr = (U8*)SvPV_const(vecsv, veclen);
vec_utf8 = DO_UTF8(vecsv);
Safefree(version);
1. */
nmg->mg_obj = SvREFCNT_inc(av_dup_inc((AV*) mg->mg_obj, param));
}
- else if (mg->mg_type == PERL_MAGIC_symtab) {
- nmg->mg_obj = mg->mg_obj;
- }
else {
nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
? sv_dup_inc(mg->mg_obj, param)
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
HINTS_REFCNT_UNLOCK;
}
PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
+#ifdef PERL_DEBUG_READONLY_OPS
+ PL_slabs = NULL;
+ PL_slab_count = 0;
+#endif
/* pseudo environmental stuff */
PL_origargc = proto_perl->Iorigargc;
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);
PL_maxscream = -1; /* reinits on demand */
PL_lastscream = NULL;
- PL_watchaddr = NULL;
- PL_watchok = NULL;
PL_regdummy = proto_perl->Tregdummy;
PL_colorset = 0; /* reinits PL_colors[] */
PL_stashcache = newHV();
+ PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table,
+ proto_perl->Twatchaddr);
+ PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL;
+ if (PL_debug && PL_watchaddr) {
+ PerlIO_printf(Perl_debug_log,
+ "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
+ PTR2UV(proto_perl->Twatchaddr), PTR2UV(PL_watchaddr),
+ PTR2UV(PL_watchok));
+ }
+
if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
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