* "A time to plant, and a time to uproot what was planted..."
*/
+
#ifdef DEBUG_LEAKING_SCALARS
# ifdef NETWARE
# define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file)
} STMT_END
+/* 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;
+
+ if (PL_nice_chunk) {
+ sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
+ PL_nice_chunk = Nullch;
+ PL_nice_chunk_size = 0;
+ }
+ else {
+ char *chunk; /* must use New here to match call to */
+ New(704,chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
+ sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
+ }
+ uproot_SV(sv);
+ return sv;
+}
+
/* new_SV(): return a new, empty SV head */
#ifdef DEBUG_LEAKING_SCALARS
if (PL_sv_root)
uproot_SV(sv);
else
- sv = more_sv();
+ sv = S_more_sv(aTHX);
UNLOCK_SV_MUTEX;
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
if (PL_sv_root) \
uproot_SV(p); \
else \
- (p) = more_sv(); \
+ (p) = S_more_sv(aTHX); \
UNLOCK_SV_MUTEX; \
SvANY(p) = 0; \
SvREFCNT(p) = 1; \
{
if (DEBUG_D_TEST) {
SV* sva;
- SV* sv;
- SV* svend;
- int ok = 0;
+ bool ok = 0;
for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
- sv = sva + 1;
- svend = &sva[SvREFCNT(sva)];
+ SV *sv = sva + 1;
+ SV *svend = &sva[SvREFCNT(sva)];
if (p >= sv && p < svend) {
ok = 1;
break;
SvFLAGS(sv) = SVTYPEMASK;
}
-/* make some more SVs by adding another arena */
-
-/* sv_mutex must be held while calling more_sv() */
-STATIC SV*
-S_more_sv(pTHX)
-{
- register SV* sv;
-
- if (PL_nice_chunk) {
- sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
- PL_nice_chunk = Nullch;
- PL_nice_chunk_size = 0;
- }
- else {
- char *chunk; /* must use New here to match call to */
- New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
- sv_add_arena(chunk, 1008, 0);
- }
- uproot_SV(sv);
- return sv;
-}
-
/* visit(): call the named function for each non-free SV in the arenas
* whose flags field matches the flags/mask args. */
S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
{
SV* sva;
- SV* sv;
- register SV* svend;
I32 visited = 0;
for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
- svend = &sva[SvREFCNT(sva)];
+ register SV * const svend = &sva[SvREFCNT(sva)];
+ register SV* sv;
for (sv = sva + 1; sv < svend; ++sv) {
if (SvTYPE(sv) != SVTYPEMASK
&& (sv->sv_flags & mask) == flags
PL_xpvmg_arenaroot = 0;
PL_xpvmg_root = 0;
+ for (arena = (XPV*)PL_xpvgv_arenaroot; arena; arena = arenanext) {
+ arenanext = (XPV*)arena->xpv_pv;
+ Safefree(arena);
+ }
+ PL_xpvgv_arenaroot = 0;
+ PL_xpvgv_root = 0;
+
for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
SV* keyname, I32 aindex, int subscript_type)
{
AV *av;
+ SV *sv;
- SV *sv, *name;
-
- name = sv_newmortal();
+ SV * const name = sv_newmortal();
if (gv) {
/* simulate gv_fullname4(), but add literal '^' for $^FOO names
"", "", "");
}
-/* grab a new IV body from the free list, allocating more if necessary */
-STATIC XPVIV*
-S_new_xiv(pTHX)
-{
- IV* xiv;
- LOCK_SV_MUTEX;
- if (!PL_xiv_root)
- more_xiv();
- xiv = PL_xiv_root;
- /*
- * See comment in more_xiv() -- RAM.
- */
- PL_xiv_root = *(IV**)xiv;
- UNLOCK_SV_MUTEX;
- return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
-}
-
-/* return an IV body to the free list */
+/* allocate another arena's worth of struct xrv */
STATIC void
-S_del_xiv(pTHX_ XPVIV *p)
+S_more_xrv(pTHX)
{
- IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
- LOCK_SV_MUTEX;
- *(IV**)xiv = PL_xiv_root;
- PL_xiv_root = xiv;
- UNLOCK_SV_MUTEX;
+ XRV* xrv;
+ XRV* xrvend;
+ XPV *ptr;
+ New(712, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV);
+ ptr->xpv_pv = (char*)PL_xrv_arenaroot;
+ PL_xrv_arenaroot = ptr;
+
+ xrv = (XRV*) ptr;
+ xrvend = &xrv[PERL_ARENA_SIZE / sizeof(XRV) - 1];
+ xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
+ PL_xrv_root = xrv;
+ while (xrv < xrvend) {
+ xrv->xrv_rv = (SV*)(xrv + 1);
+ xrv++;
+ }
+ xrv->xrv_rv = 0;
}
/* allocate another arena's worth of IV bodies */
STATIC void
S_more_xiv(pTHX)
{
- register IV* xiv;
- register IV* xivend;
+ IV* xiv;
+ IV* xivend;
XPV* ptr;
New(705, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV);
ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
*(IV**)xiv = 0;
}
-/* grab a new NV body from the free list, allocating more if necessary */
-
-STATIC XPVNV*
-S_new_xnv(pTHX)
-{
- NV* xnv;
- LOCK_SV_MUTEX;
- if (!PL_xnv_root)
- more_xnv();
- xnv = PL_xnv_root;
- PL_xnv_root = *(NV**)xnv;
- UNLOCK_SV_MUTEX;
- return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
-}
-
-/* return an NV body to the free list */
-
-STATIC void
-S_del_xnv(pTHX_ XPVNV *p)
-{
- NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
- LOCK_SV_MUTEX;
- *(NV**)xnv = PL_xnv_root;
- PL_xnv_root = xnv;
- UNLOCK_SV_MUTEX;
-}
-
/* allocate another arena's worth of NV bodies */
STATIC void
S_more_xnv(pTHX)
{
- register NV* xnv;
- register NV* xnvend;
+ NV* xnv;
+ NV* xnvend;
XPV *ptr;
New(711, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV);
ptr->xpv_pv = (char*)PL_xnv_arenaroot;
*(NV**)xnv = 0;
}
-/* grab a new struct xrv from the free list, allocating more if necessary */
+/* allocate another arena's worth of struct xpv */
+
+STATIC void
+S_more_xpv(pTHX)
+{
+ XPV* xpv;
+ XPV* xpvend;
+ New(713, xpv, PERL_ARENA_SIZE/sizeof(XPV), XPV);
+ xpv->xpv_pv = (char*)PL_xpv_arenaroot;
+ PL_xpv_arenaroot = xpv;
+
+ xpvend = &xpv[PERL_ARENA_SIZE / sizeof(XPV) - 1];
+ PL_xpv_root = ++xpv;
+ while (xpv < xpvend) {
+ xpv->xpv_pv = (char*)(xpv + 1);
+ xpv++;
+ }
+ xpv->xpv_pv = 0;
+}
+
+/* allocate another arena's worth of struct xpviv */
+
+STATIC void
+S_more_xpviv(pTHX)
+{
+ XPVIV* xpviv;
+ XPVIV* xpvivend;
+ New(714, xpviv, PERL_ARENA_SIZE/sizeof(XPVIV), XPVIV);
+ xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
+ PL_xpviv_arenaroot = xpviv;
+
+ xpvivend = &xpviv[PERL_ARENA_SIZE / sizeof(XPVIV) - 1];
+ PL_xpviv_root = ++xpviv;
+ while (xpviv < xpvivend) {
+ xpviv->xpv_pv = (char*)(xpviv + 1);
+ xpviv++;
+ }
+ xpviv->xpv_pv = 0;
+}
+
+/* allocate another arena's worth of struct xpvnv */
+
+STATIC void
+S_more_xpvnv(pTHX)
+{
+ XPVNV* xpvnv;
+ XPVNV* xpvnvend;
+ New(715, xpvnv, PERL_ARENA_SIZE/sizeof(XPVNV), XPVNV);
+ xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
+ PL_xpvnv_arenaroot = xpvnv;
+
+ xpvnvend = &xpvnv[PERL_ARENA_SIZE / sizeof(XPVNV) - 1];
+ PL_xpvnv_root = ++xpvnv;
+ while (xpvnv < xpvnvend) {
+ xpvnv->xpv_pv = (char*)(xpvnv + 1);
+ xpvnv++;
+ }
+ xpvnv->xpv_pv = 0;
+}
+
+/* allocate another arena's worth of struct xpvcv */
+
+STATIC void
+S_more_xpvcv(pTHX)
+{
+ XPVCV* xpvcv;
+ XPVCV* xpvcvend;
+ New(716, xpvcv, PERL_ARENA_SIZE/sizeof(XPVCV), XPVCV);
+ xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
+ PL_xpvcv_arenaroot = xpvcv;
+
+ xpvcvend = &xpvcv[PERL_ARENA_SIZE / sizeof(XPVCV) - 1];
+ PL_xpvcv_root = ++xpvcv;
+ while (xpvcv < xpvcvend) {
+ xpvcv->xpv_pv = (char*)(xpvcv + 1);
+ xpvcv++;
+ }
+ xpvcv->xpv_pv = 0;
+}
+
+/* allocate another arena's worth of struct xpvav */
+
+STATIC void
+S_more_xpvav(pTHX)
+{
+ XPVAV* xpvav;
+ XPVAV* xpvavend;
+ New(717, xpvav, PERL_ARENA_SIZE/sizeof(XPVAV), XPVAV);
+ xpvav->xav_array = (char*)PL_xpvav_arenaroot;
+ PL_xpvav_arenaroot = xpvav;
+
+ xpvavend = &xpvav[PERL_ARENA_SIZE / sizeof(XPVAV) - 1];
+ PL_xpvav_root = ++xpvav;
+ while (xpvav < xpvavend) {
+ xpvav->xav_array = (char*)(xpvav + 1);
+ xpvav++;
+ }
+ xpvav->xav_array = 0;
+}
+
+/* allocate another arena's worth of struct xpvhv */
+
+STATIC void
+S_more_xpvhv(pTHX)
+{
+ XPVHV* xpvhv;
+ XPVHV* xpvhvend;
+ New(718, xpvhv, PERL_ARENA_SIZE/sizeof(XPVHV), XPVHV);
+ xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
+ PL_xpvhv_arenaroot = xpvhv;
+
+ xpvhvend = &xpvhv[PERL_ARENA_SIZE / sizeof(XPVHV) - 1];
+ PL_xpvhv_root = ++xpvhv;
+ while (xpvhv < xpvhvend) {
+ xpvhv->xhv_array = (char*)(xpvhv + 1);
+ xpvhv++;
+ }
+ xpvhv->xhv_array = 0;
+}
+
+/* allocate another arena's worth of struct xpvmg */
+
+STATIC void
+S_more_xpvmg(pTHX)
+{
+ XPVMG* xpvmg;
+ XPVMG* xpvmgend;
+ New(719, xpvmg, PERL_ARENA_SIZE/sizeof(XPVMG), XPVMG);
+ xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
+ PL_xpvmg_arenaroot = xpvmg;
+
+ xpvmgend = &xpvmg[PERL_ARENA_SIZE / sizeof(XPVMG) - 1];
+ PL_xpvmg_root = ++xpvmg;
+ while (xpvmg < xpvmgend) {
+ xpvmg->xpv_pv = (char*)(xpvmg + 1);
+ xpvmg++;
+ }
+ xpvmg->xpv_pv = 0;
+}
+
+/* allocate another arena's worth of struct xpvgv */
+
+STATIC void
+S_more_xpvgv(pTHX)
+{
+ XPVGV* xpvgv;
+ XPVGV* xpvgvend;
+ New(720, xpvgv, PERL_ARENA_SIZE/sizeof(XPVGV), XPVGV);
+ xpvgv->xpv_pv = (char*)PL_xpvgv_arenaroot;
+ PL_xpvgv_arenaroot = xpvgv;
+
+ xpvgvend = &xpvgv[PERL_ARENA_SIZE / sizeof(XPVGV) - 1];
+ PL_xpvgv_root = ++xpvgv;
+ while (xpvgv < xpvgvend) {
+ xpvgv->xpv_pv = (char*)(xpvgv + 1);
+ xpvgv++;
+ }
+ xpvgv->xpv_pv = 0;
+}
+
+/* allocate another arena's worth of struct xpvlv */
+
+STATIC void
+S_more_xpvlv(pTHX)
+{
+ XPVLV* xpvlv;
+ XPVLV* xpvlvend;
+ New(720, xpvlv, PERL_ARENA_SIZE/sizeof(XPVLV), XPVLV);
+ xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
+ PL_xpvlv_arenaroot = xpvlv;
+
+ xpvlvend = &xpvlv[PERL_ARENA_SIZE / sizeof(XPVLV) - 1];
+ PL_xpvlv_root = ++xpvlv;
+ while (xpvlv < xpvlvend) {
+ xpvlv->xpv_pv = (char*)(xpvlv + 1);
+ xpvlv++;
+ }
+ xpvlv->xpv_pv = 0;
+}
+
+/* allocate another arena's worth of struct xpvbm */
+
+STATIC void
+S_more_xpvbm(pTHX)
+{
+ XPVBM* xpvbm;
+ XPVBM* xpvbmend;
+ New(721, xpvbm, PERL_ARENA_SIZE/sizeof(XPVBM), XPVBM);
+ xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
+ PL_xpvbm_arenaroot = xpvbm;
+
+ xpvbmend = &xpvbm[PERL_ARENA_SIZE / sizeof(XPVBM) - 1];
+ PL_xpvbm_root = ++xpvbm;
+ while (xpvbm < xpvbmend) {
+ xpvbm->xpv_pv = (char*)(xpvbm + 1);
+ xpvbm++;
+ }
+ xpvbm->xpv_pv = 0;
+}
+
+/* grab a new struct xrv from the free list, allocating more if necessary */
+
+STATIC XRV*
+S_new_xrv(pTHX)
+{
+ XRV* xrv;
+ LOCK_SV_MUTEX;
+ if (!PL_xrv_root)
+ S_more_xrv(aTHX);
+ xrv = PL_xrv_root;
+ PL_xrv_root = (XRV*)xrv->xrv_rv;
+ UNLOCK_SV_MUTEX;
+ return xrv;
+}
+
+/* return a struct xrv to the free list */
+
+STATIC void
+S_del_xrv(pTHX_ XRV *p)
+{
+ LOCK_SV_MUTEX;
+ p->xrv_rv = (SV*)PL_xrv_root;
+ PL_xrv_root = p;
+ UNLOCK_SV_MUTEX;
+}
+
+/* grab a new IV body from the free list, allocating more if necessary */
+
+STATIC XPVIV*
+S_new_xiv(pTHX)
+{
+ IV* xiv;
+ LOCK_SV_MUTEX;
+ if (!PL_xiv_root)
+ S_more_xiv(aTHX);
+ xiv = PL_xiv_root;
+ /*
+ * See comment in more_xiv() -- RAM.
+ */
+ PL_xiv_root = *(IV**)xiv;
+ UNLOCK_SV_MUTEX;
+ return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
+}
+
+/* return an IV body to the free list */
-STATIC XRV*
-S_new_xrv(pTHX)
+STATIC void
+S_del_xiv(pTHX_ XPVIV *p)
{
- XRV* xrv;
+ IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
LOCK_SV_MUTEX;
- if (!PL_xrv_root)
- more_xrv();
- xrv = PL_xrv_root;
- PL_xrv_root = (XRV*)xrv->xrv_rv;
+ *(IV**)xiv = PL_xiv_root;
+ PL_xiv_root = xiv;
UNLOCK_SV_MUTEX;
- return xrv;
}
-/* return a struct xrv to the free list */
+/* grab a new NV body from the free list, allocating more if necessary */
-STATIC void
-S_del_xrv(pTHX_ XRV *p)
+STATIC XPVNV*
+S_new_xnv(pTHX)
{
+ NV* xnv;
LOCK_SV_MUTEX;
- p->xrv_rv = (SV*)PL_xrv_root;
- PL_xrv_root = p;
+ if (!PL_xnv_root)
+ S_more_xnv(aTHX);
+ xnv = PL_xnv_root;
+ PL_xnv_root = *(NV**)xnv;
UNLOCK_SV_MUTEX;
+ return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
}
-/* allocate another arena's worth of struct xrv */
+/* return an NV body to the free list */
STATIC void
-S_more_xrv(pTHX)
+S_del_xnv(pTHX_ XPVNV *p)
{
- register XRV* xrv;
- register XRV* xrvend;
- XPV *ptr;
- New(712, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV);
- ptr->xpv_pv = (char*)PL_xrv_arenaroot;
- PL_xrv_arenaroot = ptr;
-
- xrv = (XRV*) ptr;
- xrvend = &xrv[PERL_ARENA_SIZE / sizeof(XRV) - 1];
- xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
- PL_xrv_root = xrv;
- while (xrv < xrvend) {
- xrv->xrv_rv = (SV*)(xrv + 1);
- xrv++;
- }
- xrv->xrv_rv = 0;
+ NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
+ LOCK_SV_MUTEX;
+ *(NV**)xnv = PL_xnv_root;
+ PL_xnv_root = xnv;
+ UNLOCK_SV_MUTEX;
}
/* grab a new struct xpv from the free list, allocating more if necessary */
XPV* xpv;
LOCK_SV_MUTEX;
if (!PL_xpv_root)
- more_xpv();
+ S_more_xpv(aTHX);
xpv = PL_xpv_root;
PL_xpv_root = (XPV*)xpv->xpv_pv;
UNLOCK_SV_MUTEX;
UNLOCK_SV_MUTEX;
}
-/* allocate another arena's worth of struct xpv */
-
-STATIC void
-S_more_xpv(pTHX)
-{
- register XPV* xpv;
- register XPV* xpvend;
- New(713, xpv, PERL_ARENA_SIZE/sizeof(XPV), XPV);
- xpv->xpv_pv = (char*)PL_xpv_arenaroot;
- PL_xpv_arenaroot = xpv;
-
- xpvend = &xpv[PERL_ARENA_SIZE / sizeof(XPV) - 1];
- PL_xpv_root = ++xpv;
- while (xpv < xpvend) {
- xpv->xpv_pv = (char*)(xpv + 1);
- xpv++;
- }
- xpv->xpv_pv = 0;
-}
-
/* grab a new struct xpviv from the free list, allocating more if necessary */
STATIC XPVIV*
XPVIV* xpviv;
LOCK_SV_MUTEX;
if (!PL_xpviv_root)
- more_xpviv();
+ S_more_xpviv(aTHX);
xpviv = PL_xpviv_root;
PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
UNLOCK_SV_MUTEX;
UNLOCK_SV_MUTEX;
}
-/* allocate another arena's worth of struct xpviv */
-
-STATIC void
-S_more_xpviv(pTHX)
-{
- register XPVIV* xpviv;
- register XPVIV* xpvivend;
- New(714, xpviv, PERL_ARENA_SIZE/sizeof(XPVIV), XPVIV);
- xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
- PL_xpviv_arenaroot = xpviv;
-
- xpvivend = &xpviv[PERL_ARENA_SIZE / sizeof(XPVIV) - 1];
- PL_xpviv_root = ++xpviv;
- while (xpviv < xpvivend) {
- xpviv->xpv_pv = (char*)(xpviv + 1);
- xpviv++;
- }
- xpviv->xpv_pv = 0;
-}
-
/* grab a new struct xpvnv from the free list, allocating more if necessary */
STATIC XPVNV*
XPVNV* xpvnv;
LOCK_SV_MUTEX;
if (!PL_xpvnv_root)
- more_xpvnv();
+ S_more_xpvnv(aTHX);
xpvnv = PL_xpvnv_root;
PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
UNLOCK_SV_MUTEX;
UNLOCK_SV_MUTEX;
}
-/* allocate another arena's worth of struct xpvnv */
-
-STATIC void
-S_more_xpvnv(pTHX)
-{
- register XPVNV* xpvnv;
- register XPVNV* xpvnvend;
- New(715, xpvnv, PERL_ARENA_SIZE/sizeof(XPVNV), XPVNV);
- xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
- PL_xpvnv_arenaroot = xpvnv;
-
- xpvnvend = &xpvnv[PERL_ARENA_SIZE / sizeof(XPVNV) - 1];
- PL_xpvnv_root = ++xpvnv;
- while (xpvnv < xpvnvend) {
- xpvnv->xpv_pv = (char*)(xpvnv + 1);
- xpvnv++;
- }
- xpvnv->xpv_pv = 0;
-}
-
/* grab a new struct xpvcv from the free list, allocating more if necessary */
STATIC XPVCV*
XPVCV* xpvcv;
LOCK_SV_MUTEX;
if (!PL_xpvcv_root)
- more_xpvcv();
+ S_more_xpvcv(aTHX);
xpvcv = PL_xpvcv_root;
PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
UNLOCK_SV_MUTEX;
UNLOCK_SV_MUTEX;
}
-/* allocate another arena's worth of struct xpvcv */
-
-STATIC void
-S_more_xpvcv(pTHX)
-{
- register XPVCV* xpvcv;
- register XPVCV* xpvcvend;
- New(716, xpvcv, PERL_ARENA_SIZE/sizeof(XPVCV), XPVCV);
- xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
- PL_xpvcv_arenaroot = xpvcv;
-
- xpvcvend = &xpvcv[PERL_ARENA_SIZE / sizeof(XPVCV) - 1];
- PL_xpvcv_root = ++xpvcv;
- while (xpvcv < xpvcvend) {
- xpvcv->xpv_pv = (char*)(xpvcv + 1);
- xpvcv++;
- }
- xpvcv->xpv_pv = 0;
-}
-
/* grab a new struct xpvav from the free list, allocating more if necessary */
STATIC XPVAV*
XPVAV* xpvav;
LOCK_SV_MUTEX;
if (!PL_xpvav_root)
- more_xpvav();
+ S_more_xpvav(aTHX);
xpvav = PL_xpvav_root;
PL_xpvav_root = (XPVAV*)xpvav->xav_array;
UNLOCK_SV_MUTEX;
UNLOCK_SV_MUTEX;
}
-/* allocate another arena's worth of struct xpvav */
-
-STATIC void
-S_more_xpvav(pTHX)
-{
- register XPVAV* xpvav;
- register XPVAV* xpvavend;
- New(717, xpvav, PERL_ARENA_SIZE/sizeof(XPVAV), XPVAV);
- xpvav->xav_array = (char*)PL_xpvav_arenaroot;
- PL_xpvav_arenaroot = xpvav;
-
- xpvavend = &xpvav[PERL_ARENA_SIZE / sizeof(XPVAV) - 1];
- PL_xpvav_root = ++xpvav;
- while (xpvav < xpvavend) {
- xpvav->xav_array = (char*)(xpvav + 1);
- xpvav++;
- }
- xpvav->xav_array = 0;
-}
-
/* grab a new struct xpvhv from the free list, allocating more if necessary */
STATIC XPVHV*
XPVHV* xpvhv;
LOCK_SV_MUTEX;
if (!PL_xpvhv_root)
- more_xpvhv();
+ S_more_xpvhv(aTHX);
xpvhv = PL_xpvhv_root;
PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
UNLOCK_SV_MUTEX;
UNLOCK_SV_MUTEX;
}
-/* allocate another arena's worth of struct xpvhv */
-
-STATIC void
-S_more_xpvhv(pTHX)
-{
- register XPVHV* xpvhv;
- register XPVHV* xpvhvend;
- New(718, xpvhv, PERL_ARENA_SIZE/sizeof(XPVHV), XPVHV);
- xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
- PL_xpvhv_arenaroot = xpvhv;
-
- xpvhvend = &xpvhv[PERL_ARENA_SIZE / sizeof(XPVHV) - 1];
- PL_xpvhv_root = ++xpvhv;
- while (xpvhv < xpvhvend) {
- xpvhv->xhv_array = (char*)(xpvhv + 1);
- xpvhv++;
- }
- xpvhv->xhv_array = 0;
-}
-
/* grab a new struct xpvmg from the free list, allocating more if necessary */
STATIC XPVMG*
XPVMG* xpvmg;
LOCK_SV_MUTEX;
if (!PL_xpvmg_root)
- more_xpvmg();
+ S_more_xpvmg(aTHX);
xpvmg = PL_xpvmg_root;
PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
UNLOCK_SV_MUTEX;
UNLOCK_SV_MUTEX;
}
-/* allocate another arena's worth of struct xpvmg */
+/* grab a new struct xpvgv from the free list, allocating more if necessary */
-STATIC void
-S_more_xpvmg(pTHX)
+STATIC XPVGV*
+S_new_xpvgv(pTHX)
{
- register XPVMG* xpvmg;
- register XPVMG* xpvmgend;
- New(719, xpvmg, PERL_ARENA_SIZE/sizeof(XPVMG), XPVMG);
- xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
- PL_xpvmg_arenaroot = xpvmg;
+ XPVGV* xpvgv;
+ LOCK_SV_MUTEX;
+ if (!PL_xpvgv_root)
+ S_more_xpvgv(aTHX);
+ xpvgv = PL_xpvgv_root;
+ PL_xpvgv_root = (XPVGV*)xpvgv->xpv_pv;
+ UNLOCK_SV_MUTEX;
+ return xpvgv;
+}
- xpvmgend = &xpvmg[PERL_ARENA_SIZE / sizeof(XPVMG) - 1];
- PL_xpvmg_root = ++xpvmg;
- while (xpvmg < xpvmgend) {
- xpvmg->xpv_pv = (char*)(xpvmg + 1);
- xpvmg++;
- }
- xpvmg->xpv_pv = 0;
+/* return a struct xpvgv to the free list */
+
+STATIC void
+S_del_xpvgv(pTHX_ XPVGV *p)
+{
+ LOCK_SV_MUTEX;
+ p->xpv_pv = (char*)PL_xpvgv_root;
+ PL_xpvgv_root = p;
+ UNLOCK_SV_MUTEX;
}
/* grab a new struct xpvlv from the free list, allocating more if necessary */
XPVLV* xpvlv;
LOCK_SV_MUTEX;
if (!PL_xpvlv_root)
- more_xpvlv();
+ S_more_xpvlv(aTHX);
xpvlv = PL_xpvlv_root;
PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
UNLOCK_SV_MUTEX;
UNLOCK_SV_MUTEX;
}
-/* allocate another arena's worth of struct xpvlv */
-
-STATIC void
-S_more_xpvlv(pTHX)
-{
- register XPVLV* xpvlv;
- register XPVLV* xpvlvend;
- New(720, xpvlv, PERL_ARENA_SIZE/sizeof(XPVLV), XPVLV);
- xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
- PL_xpvlv_arenaroot = xpvlv;
-
- xpvlvend = &xpvlv[PERL_ARENA_SIZE / sizeof(XPVLV) - 1];
- PL_xpvlv_root = ++xpvlv;
- while (xpvlv < xpvlvend) {
- xpvlv->xpv_pv = (char*)(xpvlv + 1);
- xpvlv++;
- }
- xpvlv->xpv_pv = 0;
-}
-
/* grab a new struct xpvbm from the free list, allocating more if necessary */
STATIC XPVBM*
XPVBM* xpvbm;
LOCK_SV_MUTEX;
if (!PL_xpvbm_root)
- more_xpvbm();
+ S_more_xpvbm(aTHX);
xpvbm = PL_xpvbm_root;
PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
UNLOCK_SV_MUTEX;
UNLOCK_SV_MUTEX;
}
-/* allocate another arena's worth of struct xpvbm */
-
-STATIC void
-S_more_xpvbm(pTHX)
-{
- register XPVBM* xpvbm;
- register XPVBM* xpvbmend;
- New(721, xpvbm, PERL_ARENA_SIZE/sizeof(XPVBM), XPVBM);
- xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
- PL_xpvbm_arenaroot = xpvbm;
-
- xpvbmend = &xpvbm[PERL_ARENA_SIZE / sizeof(XPVBM) - 1];
- PL_xpvbm_root = ++xpvbm;
- while (xpvbm < xpvbmend) {
- xpvbm->xpv_pv = (char*)(xpvbm + 1);
- xpvbm++;
- }
- xpvbm->xpv_pv = 0;
-}
-
#define my_safemalloc(s) (void*)safemalloc(s)
#define my_safefree(p) safefree((char*)p)
#define new_XPVMG() my_safemalloc(sizeof(XPVMG))
#define del_XPVMG(p) my_safefree(p)
+#define new_XPVGV() my_safemalloc(sizeof(XPVGV))
+#define del_XPVGV(p) my_safefree(p)
+
#define new_XPVLV() my_safemalloc(sizeof(XPVLV))
#define del_XPVLV(p) my_safefree(p)
#define new_XPVMG() (void*)new_xpvmg()
#define del_XPVMG(p) del_xpvmg((XPVMG *)p)
+#define new_XPVGV() (void*)new_xpvgv()
+#define del_XPVGV(p) del_xpvgv((XPVGV *)p)
+
#define new_XPVLV() (void*)new_xpvlv()
#define del_XPVLV(p) del_xpvlv((XPVLV *)p)
#endif /* PURIFY */
-#define new_XPVGV() my_safemalloc(sizeof(XPVGV))
-#define del_XPVGV(p) my_safefree(p)
-
#define new_XPVFM() my_safemalloc(sizeof(XPVFM))
#define del_XPVFM(p) my_safefree(p)
there's no way that it can be safely upgraded, because perl.c
expects to Safefree(SvANY(PL_mess_sv)) */
assert(sv != PL_mess_sv);
+ /* This flag bit is used to mean other things in other scalar types.
+ Given that it only has meaning inside the pad, it shouldn't be set
+ on anything that can get upgraded. */
+ assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
pv = SvPVX(sv);
cur = SvCUR(sv);
len = SvLEN(sv);
SvANY(sv) = new_XPVHV();
HvRITER(sv) = 0;
HvEITER(sv) = 0;
- HvPMROOT(sv) = 0;
HvNAME(sv) = 0;
HvFILL(sv) = 0;
HvMAX(sv) = 0;
HvTOTALKEYS(sv) = 0;
- HvPLACEHOLDERS(sv) = 0;
/* Fall through... */
if (0) {
AvFILLp(sv) = -1;
AvALLOC(sv) = 0;
AvARYLEN(sv)= 0;
- AvFLAGS(sv) = AVf_REAL;
+ AvREAL_only(sv);
SvIV_set(sv, 0);
SvNV_set(sv, 0.0);
}
if (newlen > SvLEN(sv)) { /* need more room? */
if (SvLEN(sv) && s) {
#ifdef MYMALLOC
- STRLEN l = malloced_size((void*)SvPVX(sv));
+ const STRLEN l = malloced_size((void*)SvPVX(sv));
if (newlen <= l) {
SvLEN_set(sv, l);
return s;
I32
Perl_looks_like_number(pTHX_ SV *sv)
{
- register char *sbegin;
+ register const char *sbegin;
STRLEN len;
if (SvPOK(sv)) {
case SVt_PVHV:
case SVt_PVCV:
case SVt_PVIO:
+ {
+ const char * const type = sv_reftype(sstr,0);
if (PL_op)
- Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
- OP_NAME(PL_op));
+ Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
else
- Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
+ Perl_croak(aTHX_ "Bizarre copy of %s", type);
+ }
break;
case SVt_PVGV:
if (dtype <= SVt_PVGV) {
glob_assign:
if (dtype != SVt_PVGV) {
- char *name = GvNAME(sstr);
- STRLEN len = GvNAMELEN(sstr);
+ const char * const name = GvNAME(sstr);
+ const STRLEN len = GvNAMELEN(sstr);
/* don't upgrade SVt_PVLV: it can hold a glob */
if (dtype != SVt_PVLV)
sv_upgrade(dstr, SVt_PVGV);
if (dtype == SVt_PVGV) {
SV *sref = SvREFCNT_inc(SvRV(sstr));
SV *dref = 0;
- int intro = GvINTRO(dstr);
+ const int intro = GvINTRO(dstr);
#ifdef GV_UNIQUE_CHECK
if (GvUNIQUE((GV*)dstr)) {
}
else {
/* len is STRLEN which is unsigned, need to copy to signed */
- IV iv = len;
+ const IV iv = len;
if (iv < 0)
Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
}
if (!obj || obj == sv ||
how == PERL_MAGIC_arylen ||
how == PERL_MAGIC_qr ||
+ how == PERL_MAGIC_symtab ||
(SvTYPE(obj) == SVt_PVGV &&
(GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
case PERL_MAGIC_vec:
vtable = &PL_vtbl_vec;
break;
+ case PERL_MAGIC_symtab:
case PERL_MAGIC_vstring:
vtable = 0;
break;
void
Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
{
- U32 refcnt = SvREFCNT(sv);
+ const U32 refcnt = SvREFCNT(sv);
SV_CHECK_THINKFIRST_COW_DROP(sv);
if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
if (SvTYPE(sv) >= SVt_PVMG) {
if (SvMAGIC(sv))
mg_free(sv);
- if (SvFLAGS(sv) & SVpad_TYPED)
+ if (SvTYPE(sv) == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
SvREFCNT_dec(SvSTASH(sv));
}
stash = NULL;
else
{
STRLEN len, ulen;
- U8 *s = (U8*)SvPV(sv, len);
+ const U8 *s = (U8*)SvPV(sv, len);
MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
*
*/
STATIC bool
-S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, U8 *s, U8 *start)
+S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 offsetp, U8 *s, U8 *start)
{
bool found = FALSE;
}
assert(*cachep);
- (*cachep)[i] = *offsetp;
+ (*cachep)[i] = offsetp;
(*cachep)[i+1] = s - start;
found = TRUE;
}
else { /* We will skip to the right spot. */
STRLEN forw = 0;
STRLEN backw = 0;
- U8* p = NULL;
+ const U8* p = NULL;
/* The assumption is that going backward is half
* the speed of going forward (that's where the
/* Try this only for the substr offset (i == 0),
* not for the substr length (i == 2). */
else if (i == 0) { /* (*cachep)[i] < uoff */
- STRLEN ulen = sv_len_utf8(sv);
+ const STRLEN ulen = sv_len_utf8(sv);
if ((STRLEN)uoff < ulen) {
forw = (STRLEN)uoff - (*cachep)[i];
s += UTF8SKIP(s);
if (s >= send)
s = send;
- if (utf8_mg_pos_init(sv, &mg, &cache, 0, offsetp, s, start))
+ if (utf8_mg_pos_init(sv, &mg, &cache, 0, *offsetp, s, start))
boffset = cache[1];
*offsetp = s - start;
}
s += UTF8SKIP(s);
if (s >= send)
s = send;
- utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start);
+ utf8_mg_pos_init(sv, &mg, &cache, 2, *lenp, s, start);
}
*lenp = s - start;
}
register GV *gv;
register SV *sv;
register I32 i;
- register PMOP *pm;
register I32 max;
char todo[PERL_UCHAR_MAX+1];
return;
if (!*s) { /* reset ?? searches */
- for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
- pm->op_pmdynflags &= ~PMdf_USED;
+ MAGIC *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;
+ }
}
return;
}
char *
Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
{
- char *s = NULL;
if (SvTHINKFIRST(sv) && !SvROK(sv))
sv_force_normal_flags(sv, 0);
*lp = SvCUR(sv);
}
else {
+ char *s;
if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
OP_NAME(PL_op));
else
s = sv_2pv_flags(sv, lp, flags);
if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
- STRLEN len = *lp;
+ const STRLEN len = *lp;
if (SvROK(sv))
sv_unref(sv);
SvAMAGIC_off(rv);
if (SvTYPE(rv) >= SVt_PVMG) {
- U32 refcnt = SvREFCNT(rv);
+ const U32 refcnt = SvREFCNT(rv);
SvREFCNT(rv) = 0;
sv_clear(rv);
SvFLAGS(rv) = 0;
static char *
F0convert(NV nv, char *endbuf, STRLEN *len)
{
- int neg = nv < 0;
+ const int neg = nv < 0;
UV uv;
char *p = endbuf;
if (uv & 1 && uv == nv)
uv--; /* Round to even */
do {
- unsigned dig = uv % 10;
+ const unsigned dig = uv % 10;
*--p = '0' + dig;
} while (uv /= 10);
if (neg)
{
char *p;
char *q;
- char *patend;
+ const char *patend;
STRLEN origlen;
I32 svix = 0;
static const char nullstr[] = "(null)";
/* no matter what, this is a string now */
(void)SvPV_force(sv, origlen);
- /* special-case "", "%s", and "%_" */
+ /* special-case "", "%s", and "%-p" (SVf) */
if (patlen == 0)
return;
- if (patlen == 2 && pat[0] == '%') {
- switch (pat[1]) {
- case 's':
+ if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
if (args) {
const char *s = va_arg(*args, char*);
sv_catpv(sv, s ? s : nullstr);
SvUTF8_on(sv);
}
return;
- case '_':
+ }
+ if (patlen == 3 && pat[0] == '%' &&
+ pat[1] == '-' && pat[2] == 'p') {
if (args) {
argsv = va_arg(*args, SV*);
sv_catsv(sv, argsv);
SvUTF8_on(sv);
return;
}
- /* See comment on '_' below */
- break;
- }
}
#ifndef USE_LONG_DOUBLE
is_utf8 = TRUE;
}
}
- goto string;
-
- case '_':
-#ifdef CHECK_FORMAT
- format_sv:
-#endif
- /*
- * The "%_" hack might have to be changed someday,
- * if ISO or ANSI decide to use '_' for something.
- * So we keep it hidden from users' code.
- */
- if (!args || vectorize)
- goto unknown;
- argsv = va_arg(*args, SV*);
- eptr = SvPVx(argsv, elen);
- if (DO_UTF8(argsv))
- is_utf8 = TRUE;
string:
vectorize = FALSE;
/* INTEGERS */
case 'p':
-#ifdef CHECK_FORMAT
- if (left) {
+ if (left && args) { /* SVf */
left = FALSE;
- if (!width)
- goto format_sv; /* %-p -> %_ */
- precis = width;
- has_precis = TRUE;
- width = 0;
- goto format_sv; /* %-Np -> %.N_ */
+ if (width) {
+ precis = width;
+ has_precis = TRUE;
+ width = 0;
+ }
+ if (vectorize)
+ goto unknown;
+ argsv = va_arg(*args, SV*);
+ eptr = SvPVx(argsv, elen);
+ if (DO_UTF8(argsv))
+ is_utf8 = TRUE;
+ goto string;
}
-#endif
if (alt || vectorize)
goto unknown;
uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
av_push((AV*)nmg->mg_obj,sv_dup(svp[i],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)
STATIC void
S_more_pte(pTHX)
{
- register struct ptr_tbl_ent* pte;
- register struct ptr_tbl_ent* pteend;
+ struct ptr_tbl_ent* pte;
+ struct ptr_tbl_ent* pteend;
New(0, pte, PERL_ARENA_SIZE/sizeof(struct ptr_tbl_ent), struct ptr_tbl_ent);
pte->next = PL_pte_arenaroot;
PL_pte_arenaroot = pte;
SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
- AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
if (AvARRAY((AV*)sstr)) {
SV **dst_ary, **src_ary;
SSize_t items = AvFILLp((AV*)sstr) + 1;
SvPV_set(dstr, Nullch);
HvEITER((HV*)dstr) = (HE*)NULL;
}
- HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
/* Record stashes for possible cloning in Perl_clone(). */
if(HvNAME((HV*)dstr))
PL_xpvhv_root = NULL;
PL_xpvmg_arenaroot = NULL;
PL_xpvmg_root = NULL;
+ PL_xpvgv_arenaroot = NULL;
+ PL_xpvgv_root = NULL;
PL_xpvlv_arenaroot = NULL;
PL_xpvlv_root = NULL;
PL_xpvbm_arenaroot = NULL;
/* Clone the regex array */
PL_regex_padav = newAV();
{
- I32 len = av_len((AV*)proto_perl->Iregex_padav);
+ const I32 len = av_len((AV*)proto_perl->Iregex_padav);
SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
av_push(PL_regex_padav,
sv_dup_inc(regexen[0],param));
SvREFCNT_dec(param->stashes);
+ /* orphaned? eg threads->new inside BEGIN or use */
+ if (PL_compcv && ! SvREFCNT(PL_compcv)) {
+ (void)SvREFCNT_inc(PL_compcv);
+ SAVEFREESV(PL_compcv);
+ }
+
return my_perl;
}
https://perl5.git.perl.org / perl5.git / blobdiff