pointer to the body (struct xrv, xpv, xpviv...), which contains fields
specific to each type.
-Normally, this allocation is done using arenas, which are approximately
-1K chunks of memory parcelled up into N heads or bodies. The first slot
-in each arena is reserved, and is used to hold a link to the next arena.
-In the case of heads, the unused first slot also contains some flags and
-a note of the number of slots. Snaked through each arena chain is a
+Normally, this allocation is done using arenas, which by default are
+approximately 4K chunks of memory parcelled up into N heads or bodies. The
+first slot in each arena is reserved, and is used to hold a link to the next
+arena. In the case of heads, the unused first slot also contains some flags
+and a note of the number of slots. Snaked through each arena chain is a
linked list of free items; when this becomes empty, an extra arena is
-allocated and divided up into N items which are threaded into the free
-list.
+allocated and divided up into N items which are threaded into the free list.
The following global variables are associated with arenas:
required. Also, if PURIFY is defined, arenas are abandoned altogether,
with all items individually malloc()ed. In addition, a few SV heads are
not allocated from an arena, but are instead directly created as static
-or auto variables, eg PL_sv_undef.
+or auto variables, eg PL_sv_undef. The size of arenas can be changed from
+the default by setting PERL_ARENA_SIZE appropriately at compile time.
The SV arena serves the secondary purpose of allowing still-live SVs
to be located and destroyed during final cleanup.
* "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)];
- if (p >= sv && p < svend)
+ SV *sv = sva + 1;
+ SV *svend = &sva[SvREFCNT(sva)];
+ if (p >= sv && p < svend) {
ok = 1;
+ break;
+ }
}
if (!ok) {
if (ckWARN_d(WARN_INTERNAL))
sv = sva + 1;
while (sv < svend) {
SvANY(sv) = (void *)(SV*)(sv + 1);
+#ifdef DEBUGGING
SvREFCNT(sv) = 0;
+#endif
+ /* Must always set typemask because it's awlays checked in on cleanup
+ when the arenas are walked looking for objects. */
SvFLAGS(sv) = SVTYPEMASK;
sv++;
}
SvANY(sv) = 0;
+#ifdef DEBUGGING
+ SvREFCNT(sv) = 0;
+#endif
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 Safefree() */
- New(704,chunk,PERL_ARENA_SIZE,char); /* in sv_free_arenas() */
- sv_add_arena(chunk, PERL_ARENA_SIZE, 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
{
SV* sva;
SV* svanext;
- XPV *arena, *arenanext;
+ void *arena, *arenanext;
/* Free arenas here, but be careful about fake ones. (We assume
contiguity of the fake ones with the corresponding real ones.) */
Safefree((void *)sva);
}
- for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
- Safefree(arena);
- }
- PL_xiv_arenaroot = 0;
- PL_xiv_root = 0;
-
for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ arenanext = *(void **)arena;
Safefree(arena);
}
PL_xnv_arenaroot = 0;
PL_xnv_root = 0;
- for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
- Safefree(arena);
- }
- PL_xrv_arenaroot = 0;
- PL_xrv_root = 0;
-
for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ arenanext = *(void **)arena;
Safefree(arena);
}
PL_xpv_arenaroot = 0;
PL_xpv_root = 0;
- for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ for (arena = PL_xpviv_arenaroot; arena; arena = arenanext) {
+ arenanext = *(void **)arena;
Safefree(arena);
}
PL_xpviv_arenaroot = 0;
PL_xpviv_root = 0;
- for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ for (arena = PL_xpvnv_arenaroot; arena; arena = arenanext) {
+ arenanext = *(void **)arena;
Safefree(arena);
}
PL_xpvnv_arenaroot = 0;
PL_xpvnv_root = 0;
- for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ for (arena = PL_xpvcv_arenaroot; arena; arena = arenanext) {
+ arenanext = *(void **)arena;
Safefree(arena);
}
PL_xpvcv_arenaroot = 0;
PL_xpvcv_root = 0;
- for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ for (arena = PL_xpvav_arenaroot; arena; arena = arenanext) {
+ arenanext = *(void **)arena;
Safefree(arena);
}
PL_xpvav_arenaroot = 0;
PL_xpvav_root = 0;
- for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ for (arena = PL_xpvhv_arenaroot; arena; arena = arenanext) {
+ arenanext = *(void **)arena;
Safefree(arena);
}
PL_xpvhv_arenaroot = 0;
PL_xpvhv_root = 0;
- for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ for (arena = PL_xpvmg_arenaroot; arena; arena = arenanext) {
+ arenanext = *(void **)arena;
Safefree(arena);
}
PL_xpvmg_arenaroot = 0;
PL_xpvmg_root = 0;
- for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ for (arena = PL_xpvgv_arenaroot; arena; arena = arenanext) {
+ arenanext = *(void **)arena;
+ Safefree(arena);
+ }
+ PL_xpvgv_arenaroot = 0;
+ PL_xpvgv_root = 0;
+
+ for (arena = PL_xpvlv_arenaroot; arena; arena = arenanext) {
+ arenanext = *(void **)arena;
Safefree(arena);
}
PL_xpvlv_arenaroot = 0;
PL_xpvlv_root = 0;
- for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ for (arena = PL_xpvbm_arenaroot; arena; arena = arenanext) {
+ arenanext = *(void **)arena;
Safefree(arena);
}
PL_xpvbm_arenaroot = 0;
{
dVAR;
register HE **array;
- register HE *entry;
I32 i;
if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
array = HvARRAY(hv);
for (i=HvMAX(hv); i>0; i--) {
+ register HE *entry;
for (entry = array[i]; entry; entry = HeNEXT(entry)) {
if (HeVAL(entry) != val)
continue;
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
sv_setpv(name, gvtype);
if (!hv)
p = "???";
- else if (!(p=HvNAME(hv)))
+ else if (!(p=HvNAME_get(hv)))
p = "__ANON__";
if (strNE(p, "main")) {
sv_catpv(name,p);
case OP_PADAV:
case OP_PADHV:
{
- bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
- bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
+ const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
+ const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
I32 index = 0;
SV *keysv = Nullsv;
int subscript_type = FUV_SUBSCRIPT_WITHIN;
keysv, 0, FUV_SUBSCRIPT_HASH);
}
else {
- I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
+ const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
if (index >= 0)
- return S_varname(aTHX_ gv, "@", o->op_targ,
+ return S_varname(aTHX_ gv, "@", o->op_targ,
Nullsv, index, FUV_SUBSCRIPT_ARRAY);
}
if (match)
"", "", "");
}
-/* grab a new IV body from the free list, allocating more if necessary */
+/* allocate another arena's worth of NV bodies */
-STATIC XPVIV*
-S_new_xiv(pTHX)
+STATIC void
+S_more_xnv(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));
+ NV* xnv;
+ NV* xnvend;
+ void *ptr;
+ New(711, ptr, PERL_ARENA_SIZE/sizeof(NV), NV);
+ *((void **) ptr) = (void *)PL_xnv_arenaroot;
+ PL_xnv_arenaroot = ptr;
+
+ xnv = (NV*) ptr;
+ xnvend = &xnv[PERL_ARENA_SIZE / sizeof(NV) - 1];
+ xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
+ PL_xnv_root = xnv;
+ while (xnv < xnvend) {
+ *(NV**)xnv = (NV*)(xnv + 1);
+ xnv++;
+ }
+ *(NV**)xnv = 0;
}
-/* return an IV body to the free list */
+/* allocate another arena's worth of struct xpv */
STATIC void
-S_del_xiv(pTHX_ XPVIV *p)
+S_more_xpv(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;
+ XPV* xpv;
+ XPV* xpvend;
+ New(713, xpv, PERL_ARENA_SIZE/sizeof(XPV), XPV);
+ *((XPV**)xpv) = PL_xpv_arenaroot;
+ PL_xpv_arenaroot = xpv;
+
+ xpvend = &xpv[PERL_ARENA_SIZE / sizeof(XPV) - 1];
+ PL_xpv_root = ++xpv;
+ while (xpv < xpvend) {
+ *((XPV**)xpv) = xpv + 1;
+ xpv++;
+ }
+ *((XPV**)xpv) = 0;
}
-/* allocate another arena's worth of IV bodies */
+/* allocate another arena's worth of struct xpviv */
STATIC void
-S_more_xiv(pTHX)
+S_more_xpviv(pTHX)
{
- register IV* xiv;
- register 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 */
- PL_xiv_arenaroot = ptr; /* to keep Purify happy */
+ XPVIV* xpviv;
+ XPVIV* xpvivend;
+ New(714, xpviv, PERL_ARENA_SIZE/sizeof(XPVIV), XPVIV);
+ *((XPVIV**)xpviv) = PL_xpviv_arenaroot;
+ PL_xpviv_arenaroot = xpviv;
- xiv = (IV*) ptr;
- xivend = &xiv[PERL_ARENA_SIZE / sizeof(IV) - 1];
- xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
- PL_xiv_root = xiv;
- while (xiv < xivend) {
- *(IV**)xiv = (IV *)(xiv + 1);
- xiv++;
+ xpvivend = &xpviv[PERL_ARENA_SIZE / sizeof(XPVIV) - 1];
+ PL_xpviv_root = ++xpviv;
+ while (xpviv < xpvivend) {
+ *((XPVIV**)xpviv) = xpviv + 1;
+ xpviv++;
}
- *(IV**)xiv = 0;
+ *((XPVIV**)xpviv) = 0;
}
-/* grab a new NV body from the free list, allocating more if necessary */
+/* allocate another arena's worth of struct xpvnv */
-STATIC XPVNV*
-S_new_xnv(pTHX)
+STATIC void
+S_more_xpvnv(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));
+ XPVNV* xpvnv;
+ XPVNV* xpvnvend;
+ New(715, xpvnv, PERL_ARENA_SIZE/sizeof(XPVNV), XPVNV);
+ *((XPVNV**)xpvnv) = PL_xpvnv_arenaroot;
+ PL_xpvnv_arenaroot = xpvnv;
+
+ xpvnvend = &xpvnv[PERL_ARENA_SIZE / sizeof(XPVNV) - 1];
+ PL_xpvnv_root = ++xpvnv;
+ while (xpvnv < xpvnvend) {
+ *((XPVNV**)xpvnv) = xpvnv + 1;
+ xpvnv++;
+ }
+ *((XPVNV**)xpvnv) = 0;
}
-/* return an NV body to the free list */
+/* allocate another arena's worth of struct xpvcv */
STATIC void
-S_del_xnv(pTHX_ XPVNV *p)
+S_more_xpvcv(pTHX)
{
- 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;
+ XPVCV* xpvcv;
+ XPVCV* xpvcvend;
+ New(716, xpvcv, PERL_ARENA_SIZE/sizeof(XPVCV), XPVCV);
+ *((XPVCV**)xpvcv) = PL_xpvcv_arenaroot;
+ PL_xpvcv_arenaroot = xpvcv;
+
+ xpvcvend = &xpvcv[PERL_ARENA_SIZE / sizeof(XPVCV) - 1];
+ PL_xpvcv_root = ++xpvcv;
+ while (xpvcv < xpvcvend) {
+ *((XPVCV**)xpvcv) = xpvcv + 1;
+ xpvcv++;
+ }
+ *((XPVCV**)xpvcv) = 0;
}
-/* allocate another arena's worth of NV bodies */
+/* allocate another arena's worth of struct xpvav */
STATIC void
-S_more_xnv(pTHX)
+S_more_xpvav(pTHX)
{
- register NV* xnv;
- register NV* xnvend;
- XPV *ptr;
- New(711, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV);
- ptr->xpv_pv = (char*)PL_xnv_arenaroot;
- PL_xnv_arenaroot = ptr;
+ XPVAV* xpvav;
+ XPVAV* xpvavend;
+ New(717, xpvav, PERL_ARENA_SIZE/sizeof(XPVAV), XPVAV);
+ *((XPVAV**)xpvav) = PL_xpvav_arenaroot;
+ PL_xpvav_arenaroot = xpvav;
- xnv = (NV*) ptr;
- xnvend = &xnv[PERL_ARENA_SIZE / sizeof(NV) - 1];
- xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
- PL_xnv_root = xnv;
- while (xnv < xnvend) {
- *(NV**)xnv = (NV*)(xnv + 1);
- xnv++;
+ xpvavend = &xpvav[PERL_ARENA_SIZE / sizeof(XPVAV) - 1];
+ PL_xpvav_root = ++xpvav;
+ while (xpvav < xpvavend) {
+ *((XPVAV**)xpvav) = xpvav + 1;
+ xpvav++;
}
- *(NV**)xnv = 0;
+ *((XPVAV**)xpvav) = 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**)xpvhv) = PL_xpvhv_arenaroot;
+ PL_xpvhv_arenaroot = xpvhv;
+
+ xpvhvend = &xpvhv[PERL_ARENA_SIZE / sizeof(XPVHV) - 1];
+ PL_xpvhv_root = ++xpvhv;
+ while (xpvhv < xpvhvend) {
+ *((XPVHV**)xpvhv) = xpvhv + 1;
+ xpvhv++;
+ }
+ *((XPVHV**)xpvhv) = 0;
}
-/* grab a new struct xrv from the free list, allocating more if necessary */
+/* allocate another arena's worth of struct xpvmg */
-STATIC XRV*
-S_new_xrv(pTHX)
+STATIC void
+S_more_xpvmg(pTHX)
{
- XRV* xrv;
- LOCK_SV_MUTEX;
- if (!PL_xrv_root)
- more_xrv();
- xrv = PL_xrv_root;
- PL_xrv_root = (XRV*)xrv->xrv_rv;
- UNLOCK_SV_MUTEX;
- return xrv;
+ XPVMG* xpvmg;
+ XPVMG* xpvmgend;
+ New(719, xpvmg, PERL_ARENA_SIZE/sizeof(XPVMG), XPVMG);
+ *((XPVMG**)xpvmg) = PL_xpvmg_arenaroot;
+ PL_xpvmg_arenaroot = xpvmg;
+
+ xpvmgend = &xpvmg[PERL_ARENA_SIZE / sizeof(XPVMG) - 1];
+ PL_xpvmg_root = ++xpvmg;
+ while (xpvmg < xpvmgend) {
+ *((XPVMG**)xpvmg) = xpvmg + 1;
+ xpvmg++;
+ }
+ *((XPVMG**)xpvmg) = 0;
}
-/* return a struct xrv to the free list */
+/* allocate another arena's worth of struct xpvgv */
STATIC void
-S_del_xrv(pTHX_ XRV *p)
+S_more_xpvgv(pTHX)
{
- LOCK_SV_MUTEX;
- p->xrv_rv = (SV*)PL_xrv_root;
- PL_xrv_root = p;
- UNLOCK_SV_MUTEX;
+ XPVGV* xpvgv;
+ XPVGV* xpvgvend;
+ New(720, xpvgv, PERL_ARENA_SIZE/sizeof(XPVGV), XPVGV);
+ *((XPVGV**)xpvgv) = PL_xpvgv_arenaroot;
+ PL_xpvgv_arenaroot = xpvgv;
+
+ xpvgvend = &xpvgv[PERL_ARENA_SIZE / sizeof(XPVGV) - 1];
+ PL_xpvgv_root = ++xpvgv;
+ while (xpvgv < xpvgvend) {
+ *((XPVGV**)xpvgv) = xpvgv + 1;
+ xpvgv++;
+ }
+ *((XPVGV**)xpvgv) = 0;
}
-/* allocate another arena's worth of struct xrv */
+/* allocate another arena's worth of struct xpvlv */
STATIC void
-S_more_xrv(pTHX)
+S_more_xpvlv(pTHX)
{
- 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;
+ XPVLV* xpvlv;
+ XPVLV* xpvlvend;
+ New(720, xpvlv, PERL_ARENA_SIZE/sizeof(XPVLV), XPVLV);
+ *((XPVLV**)xpvlv) = PL_xpvlv_arenaroot;
+ PL_xpvlv_arenaroot = xpvlv;
- 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++;
+ xpvlvend = &xpvlv[PERL_ARENA_SIZE / sizeof(XPVLV) - 1];
+ PL_xpvlv_root = ++xpvlv;
+ while (xpvlv < xpvlvend) {
+ *((XPVLV**)xpvlv) = xpvlv + 1;
+ xpvlv++;
}
- xrv->xrv_rv = 0;
+ *((XPVLV**)xpvlv) = 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**)xpvbm) = PL_xpvbm_arenaroot;
+ PL_xpvbm_arenaroot = xpvbm;
+
+ xpvbmend = &xpvbm[PERL_ARENA_SIZE / sizeof(XPVBM) - 1];
+ PL_xpvbm_root = ++xpvbm;
+ while (xpvbm < xpvbmend) {
+ *((XPVBM**)xpvbm) = xpvbm + 1;
+ xpvbm++;
+ }
+ *((XPVBM**)xpvbm) = 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)
+ 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));
+}
+
+/* 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;
}
/* 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;
+ PL_xpv_root = *(XPV**)xpv;
UNLOCK_SV_MUTEX;
return xpv;
}
S_del_xpv(pTHX_ XPV *p)
{
LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpv_root;
+ *(XPV**)p = PL_xpv_root;
PL_xpv_root = p;
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;
+ PL_xpviv_root = *(XPVIV**)xpviv;
UNLOCK_SV_MUTEX;
return xpviv;
}
S_del_xpviv(pTHX_ XPVIV *p)
{
LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpviv_root;
+ *(XPVIV**)p = PL_xpviv_root;
PL_xpviv_root = p;
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;
+ PL_xpvnv_root = *(XPVNV**)xpvnv;
UNLOCK_SV_MUTEX;
return xpvnv;
}
S_del_xpvnv(pTHX_ XPVNV *p)
{
LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpvnv_root;
+ *(XPVNV**)p = PL_xpvnv_root;
PL_xpvnv_root = p;
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;
+ PL_xpvcv_root = *(XPVCV**)xpvcv;
UNLOCK_SV_MUTEX;
return xpvcv;
}
S_del_xpvcv(pTHX_ XPVCV *p)
{
LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpvcv_root;
+ *(XPVCV**)p = PL_xpvcv_root;
PL_xpvcv_root = p;
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;
+ PL_xpvav_root = *(XPVAV**)xpvav;
UNLOCK_SV_MUTEX;
return xpvav;
}
S_del_xpvav(pTHX_ XPVAV *p)
{
LOCK_SV_MUTEX;
- p->xav_array = (char*)PL_xpvav_root;
+ *(XPVAV**)p = PL_xpvav_root;
PL_xpvav_root = p;
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;
+ PL_xpvhv_root = *(XPVHV**)xpvhv;
UNLOCK_SV_MUTEX;
return xpvhv;
}
S_del_xpvhv(pTHX_ XPVHV *p)
{
LOCK_SV_MUTEX;
- p->xhv_array = (char*)PL_xpvhv_root;
+ *(XPVHV**)p = PL_xpvhv_root;
PL_xpvhv_root = p;
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;
+ PL_xpvmg_root = *(XPVMG**)xpvmg;
UNLOCK_SV_MUTEX;
return xpvmg;
}
S_del_xpvmg(pTHX_ XPVMG *p)
{
LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpvmg_root;
+ *(XPVMG**)p = PL_xpvmg_root;
PL_xpvmg_root = p;
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;
+ 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;
+ *(XPVGV**)p = 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;
+ PL_xpvlv_root = *(XPVLV**)xpvlv;
UNLOCK_SV_MUTEX;
return xpvlv;
}
S_del_xpvlv(pTHX_ XPVLV *p)
{
LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpvlv_root;
+ *(XPVLV**)p = PL_xpvlv_root;
PL_xpvlv_root = p;
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;
+ PL_xpvbm_root = *(XPVBM**)xpvbm;
UNLOCK_SV_MUTEX;
return xpvbm;
}
S_del_xpvbm(pTHX_ XPVBM *p)
{
LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpvbm_root;
+ *(XPVBM**)p = PL_xpvbm_root;
PL_xpvbm_root = p;
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)
#ifdef PURIFY
-#define new_XIV() my_safemalloc(sizeof(XPVIV))
-#define del_XIV(p) my_safefree(p)
-
#define new_XNV() my_safemalloc(sizeof(XPVNV))
#define del_XNV(p) my_safefree(p)
-#define new_XRV() my_safemalloc(sizeof(XRV))
-#define del_XRV(p) my_safefree(p)
-
#define new_XPV() my_safemalloc(sizeof(XPV))
#define del_XPV(p) my_safefree(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)
#else /* !PURIFY */
-#define new_XIV() (void*)new_xiv()
-#define del_XIV(p) del_xiv((XPVIV*) p)
-
#define new_XNV() (void*)new_xnv()
#define del_XNV(p) del_xnv((XPVNV*) p)
-#define new_XRV() (void*)new_xrv()
-#define del_XRV(p) del_xrv((XRV*) p)
-
#define new_XPV() (void*)new_xpv()
#define del_XPV(p) del_xpv((XPV *)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)
break;
case SVt_IV:
iv = SvIVX(sv);
- del_XIV(SvANY(sv));
if (mt == SVt_NV)
mt = SVt_PVNV;
else if (mt < SVt_PVIV)
break;
case SVt_RV:
pv = (char*)SvRV(sv);
- del_XRV(SvANY(sv));
break;
case SVt_PV:
pv = SvPVX(sv);
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);
case SVt_NULL:
Perl_croak(aTHX_ "Can't upgrade to undef");
case SVt_IV:
- SvANY(sv) = new_XIV();
+ SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.sv_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
SvIV_set(sv, iv);
break;
case SVt_NV:
SvNV_set(sv, nv);
break;
case SVt_RV:
- SvANY(sv) = new_XRV();
+ SvANY(sv) = &sv->sv_u.sv_rv;
SvRV_set(sv, (SV*)pv);
break;
case SVt_PVHV:
SvANY(sv) = new_XPVHV();
- HvRITER(sv) = 0;
- HvEITER(sv) = 0;
- HvPMROOT(sv) = 0;
- HvNAME(sv) = 0;
+ ((XPVHV*) SvANY(sv))->xhv_aux = 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)) {
}
else if (SvPOKp(sv) && SvLEN(sv)) {
UV value;
- int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
+ const int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
/* We want to avoid a possible problem when we cache an IV which
may be later translated to an NV, and the resulting NV is not
the same as the direct translation of the initial string
}
else if (SvPOKp(sv) && SvLEN(sv)) {
UV value;
- int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
+ const int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
/* We want to avoid a possible problem when we cache a UV which
may be later translated to an NV, and the resulting NV is not
}
else if (SvPOKp(sv) && SvLEN(sv)) {
UV value;
- int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
+ const int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
not_a_number(sv);
#ifdef NV_PRESERVES_UV
}
tsv = NEWSV(0,0);
if (SvOBJECT(sv)) {
- const char *name = HvNAME(SvSTASH(sv));
+ const char *name = HvNAME_get(SvSTASH(sv));
Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
name ? name : "__ANON__" , typestr, PTR2UV(sv));
}
if (SvPOKp(sv)) {
register XPV* Xpvtmp;
if ((Xpvtmp = (XPV*)SvANY(sv)) &&
- (*Xpvtmp->xpv_pv > '0' ||
+ (*sv->sv_u.sv_pv > '0' ||
Xpvtmp->xpv_cur > 1 ||
- (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
+ (Xpvtmp->xpv_cur && *sv->sv_u.sv_pv != '0')))
return 1;
else
return 0;
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)) {
CvCONST(cv)
? "Constant subroutine %s::%s redefined"
: "Subroutine %s::%s redefined",
- HvNAME(GvSTASH((GV*)dstr)),
+ HvNAME_get(GvSTASH((GV*)dstr)),
GvENAME((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");
}
*/
void
-Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
+Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
{
register STRLEN delta;
if (!ptr || !SvPOKp(sv))
if (!SvOOK(sv)) {
if (!SvLEN(sv)) { /* make copy of shared string */
- char *pvx = SvPVX(sv);
+ const char *pvx = SvPVX(sv);
STRLEN len = SvCUR(sv);
SvGROW(sv, len + 1);
Move(pvx,SvPVX(sv),len,char);
Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
{
STRLEN dlen;
- char *dstr;
+ const char *dstr = SvPV_force_flags(dsv, dlen, flags);
- dstr = SvPV_force_flags(dsv, dlen, flags);
SvGROW(dsv, dlen + slen + 1);
if (sstr == dstr)
sstr = SvPVX(dsv);
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_rhash:
+ 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()");
#else
StructCopy(nsv,sv,SV);
#endif
+ /* Currently could join these into one piece of pointer arithmetic, but
+ it would be unclear. */
+ if(SvTYPE(sv) == SVt_IV)
+ SvANY(sv)
+ = (XPVIV*)((char*)&(sv->sv_u.sv_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
+ else if (SvTYPE(sv) == SVt_RV) {
+ SvANY(sv) = &sv->sv_u.sv_rv;
+ }
+
#ifdef PERL_COPY_ON_WRITE
if (SvIsCOW_normal(nsv)) {
if (SvREFCNT(sv)) {
if (PL_in_clean_objs)
Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
- HvNAME(stash));
+ HvNAME_get(stash));
/* DESTROY gave object new lease on life */
return;
}
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;
case SVt_NULL:
break;
case SVt_IV:
- del_XIV(SvANY(sv));
break;
case SVt_NV:
del_XNV(SvANY(sv));
break;
case SVt_RV:
- del_XRV(SvANY(sv));
break;
case SVt_PV:
del_XPV(SvANY(sv));
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;
}
*/
Stat_t st;
if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
- Off_t offset = PerlIO_tell(fp);
+ const Off_t offset = PerlIO_tell(fp);
if (offset != (Off_t) -1 && st.st_size + append > offset) {
(void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
}
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;
}
if (GvAV(gv)) {
av_clear(GvAV(gv));
}
- if (GvHV(gv) && !HvNAME(GvHV(gv))) {
+ if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
hv_clear(GvHV(gv));
#ifndef PERL_MICRO
#ifdef USE_ENVIRON_ARRAY
const register XPV* tXpv;
if ((tXpv = (XPV*)SvANY(sv)) &&
(tXpv->xpv_cur > 1 ||
- (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
+ (tXpv->xpv_cur && *sv->sv_u.sv_pv != '0')))
return 1;
else
return 0;
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);
/* The fact that I don't need to downcast to char * everywhere, only in ?:
inside return suggests a const propagation bug in g++. */
if (ob && SvOBJECT(sv)) {
- char *name = HvNAME(SvSTASH(sv));
+ char *name = HvNAME_get(SvSTASH(sv));
return name ? name : (char *) "__ANON__";
}
else {
int
Perl_sv_isa(pTHX_ SV *sv, const char *name)
{
+ const char *hvname;
if (!sv)
return 0;
if (SvGMAGICAL(sv))
sv = (SV*)SvRV(sv);
if (!SvOBJECT(sv))
return 0;
- if (!HvNAME(SvSTASH(sv)))
+ hvname = HvNAME_get(SvSTASH(sv));
+ if (!hvname)
return 0;
- return strEQ(HvNAME(SvSTASH(sv)), name);
+ return strEQ(hvname, name);
}
/*
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;
if (!GvUNIQUE(gv)) {
#if 0
PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
- HvNAME(GvSTASH(gv)), GvNAME(gv));
+ HvNAME_get(GvSTASH(gv)), GvNAME(gv));
#endif
return Nullsv;
}
if(param->flags & CLONEf_JOIN_IN) {
/** We are joining here so we don't want do clone
something that is bad **/
+ const char *hvname;
if(SvTYPE(sstr) == SVt_PVHV &&
- HvNAME(sstr)) {
+ (hvname = HvNAME_get(sstr))) {
/** don't clone stashes if they already exist **/
- HV* old_stash = gv_stashpv(HvNAME(sstr),0);
+ HV* old_stash = gv_stashpv(hvname,0);
return (SV*) old_stash;
}
}
SvANY(dstr) = NULL;
break;
case SVt_IV:
- SvANY(dstr) = new_XIV();
+ SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.sv_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
SvIV_set(dstr, SvIVX(sstr));
break;
case SVt_NV:
SvNV_set(dstr, SvNVX(sstr));
break;
case SVt_RV:
- SvANY(dstr) = new_XRV();
+ SvANY(dstr) = &(dstr->sv_u.sv_rv);
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
case SVt_PV:
ptr_table_store(PL_ptr_table, sstr, dstr);
#if 0
PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
- HvNAME(GvSTASH(share)), GvNAME(share));
+ HvNAME_get(GvSTASH(share)), GvNAME(share));
#endif
break;
}
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;
SvNV_set(dstr, SvNVX(sstr));
SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
- HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
- if (HvARRAY((HV*)sstr)) {
- STRLEN i = 0;
- XPVHV *dxhv = (XPVHV*)SvANY(dstr);
- XPVHV *sxhv = (XPVHV*)SvANY(sstr);
- Newz(0, dxhv->xhv_array,
- PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
- while (i <= sxhv->xhv_max) {
- ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
- (bool)!!HvSHAREKEYS(sstr),
- param);
- ++i;
+ {
+ const char *hvname = HvNAME_get((HV*)sstr);
+ struct xpvhv_aux *aux = ((XPVHV *)SvANY(sstr))->xhv_aux;
+
+ if (aux) {
+ New(0, ((XPVHV *)SvANY(dstr))->xhv_aux, 1, struct xpvhv_aux);
+ HvRITER_set((HV*)dstr, HvRITER_get((HV*)sstr));
+ /* FIXME strlen HvNAME */
+ Perl_hv_name_set(aTHX_ (HV*) dstr, hvname,
+ hvname ? strlen(hvname) : 0,
+ 0);
+ } else {
+ ((XPVHV *)SvANY(dstr))->xhv_aux = 0;
}
- dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
- (bool)!!HvSHAREKEYS(sstr), param);
- }
- else {
- SvPV_set(dstr, Nullch);
- HvEITER((HV*)dstr) = (HE*)NULL;
+ if (HvARRAY((HV*)sstr)) {
+ STRLEN i = 0;
+ XPVHV *dxhv = (XPVHV*)SvANY(dstr);
+ XPVHV *sxhv = (XPVHV*)SvANY(sstr);
+ char *darray;
+ /* FIXME - surely this doesn't need to be zeroed? */
+ Newz(0, darray,
+ PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
+ HvARRAY(dstr) = (HE**)darray;
+ while (i <= sxhv->xhv_max) {
+ HvARRAY(dstr)[i]
+ = he_dup(HvARRAY(sstr)[i],
+ (bool)!!HvSHAREKEYS(sstr), param);
+ ++i;
+ }
+ HvEITER_set(dstr, he_dup(HvEITER_get(sstr),
+ (bool)!!HvSHAREKEYS(sstr), param));
+ }
+ else {
+ SvPV_set(dstr, Nullch);
+ HvEITER_set((HV*)dstr, (HE*)NULL);
+ }
+ /* Record stashes for possible cloning in Perl_clone(). */
+ if(hvname)
+ av_push(param->stashes, dstr);
}
- 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))
- av_push(param->stashes, dstr);
break;
case SVt_PVFM:
SvANY(dstr) = new_XPVFM();
static void
do_mark_cloneable_stash(pTHX_ SV *sv)
{
- if (HvNAME((HV*)sv)) {
+ const char *hvname = HvNAME_get((HV*)sv);
+ if (hvname) {
GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
if (cloner && GvCV(cloner)) {
ENTER;
SAVETMPS;
PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVpv(HvNAME((HV*)sv), 0)));
+ XPUSHs(sv_2mortal(newSVpv(hvname, 0)));
PUTBACK;
call_sv((SV*)GvCV(cloner), G_SCALAR);
SPAGAIN;
param->proto_perl = proto_perl;
/* arena roots */
- PL_xiv_arenaroot = NULL;
- PL_xiv_root = NULL;
PL_xnv_arenaroot = NULL;
PL_xnv_root = NULL;
- PL_xrv_arenaroot = NULL;
- PL_xrv_root = NULL;
PL_xpv_arenaroot = NULL;
PL_xpv_root = NULL;
PL_xpviv_arenaroot = NULL;
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));
ENTER;
SAVETMPS;
PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
+ XPUSHs(sv_2mortal(newSVpv(HvNAME_get(stash), 0)));
PUTBACK;
call_sv((SV*)GvCV(cloner), G_DISCARD);
FREETMPS;
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;
}
* indent-tabs-mode: t
* End:
*
- * vim: shiftwidth=4:
-*/
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */