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 */
- 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
{
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;
PL_xpvbm_root = 0;
- for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
- Safefree(arena);
+ {
+ HE *he;
+ HE *he_next;
+ for (he = PL_he_arenaroot; he; he = he_next) {
+ he_next = HeNEXT(he);
+ Safefree(he);
+ }
}
PL_he_arenaroot = 0;
PL_he_root = 0;
+#if defined(USE_ITHREADS)
+ {
+ struct ptr_tbl_ent *pte;
+ struct ptr_tbl_ent *pte_next;
+ for (pte = PL_pte_arenaroot; pte; pte = pte_next) {
+ pte_next = pte->next;
+ Safefree(pte);
+ }
+ }
+ PL_pte_arenaroot = 0;
+ PL_pte_root = 0;
+#endif
+
if (PL_nice_chunk)
Safefree(PL_nice_chunk);
PL_nice_chunk = Nullch;
STATIC SV*
S_find_hash_subscript(pTHX_ HV *hv, SV* val)
{
+ 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);
STATIC SV *
S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
{
+ dVAR;
SV *sv;
AV *av;
SV **svp;
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_allocated* xpv;
+ xpv_allocated* xpvend;
+ New(713, xpv, PERL_ARENA_SIZE/sizeof(xpv_allocated), xpv_allocated);
+ *((xpv_allocated**)xpv) = PL_xpv_arenaroot;
+ PL_xpv_arenaroot = xpv;
+
+ xpvend = &xpv[PERL_ARENA_SIZE / sizeof(xpv_allocated) - 1];
+ PL_xpv_root = ++xpv;
+ while (xpv < xpvend) {
+ *((xpv_allocated**)xpv) = xpv + 1;
+ xpv++;
+ }
+ *((xpv_allocated**)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, 1008/sizeof(XPV), XPV);
- ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
- PL_xiv_arenaroot = ptr; /* to keep Purify happy */
+ xpviv_allocated* xpviv;
+ xpviv_allocated* xpvivend;
+ New(713, xpviv, PERL_ARENA_SIZE/sizeof(xpviv_allocated), xpviv_allocated);
+ *((xpviv_allocated**)xpviv) = PL_xpviv_arenaroot;
+ PL_xpviv_arenaroot = xpviv;
- xiv = (IV*) ptr;
- xivend = &xiv[1008 / 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_allocated) - 1];
+ PL_xpviv_root = ++xpviv;
+ while (xpviv < xpvivend) {
+ *((xpviv_allocated**)xpviv) = xpviv + 1;
+ xpviv++;
}
- *(IV**)xiv = 0;
+ *((xpviv_allocated**)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, 1008/sizeof(XPV), XPV);
- ptr->xpv_pv = (char*)PL_xnv_arenaroot;
- PL_xnv_arenaroot = ptr;
+ xpvav_allocated* xpvav;
+ xpvav_allocated* xpvavend;
+ New(717, xpvav, PERL_ARENA_SIZE/sizeof(xpvav_allocated),
+ xpvav_allocated);
+ *((xpvav_allocated**)xpvav) = PL_xpvav_arenaroot;
+ PL_xpvav_arenaroot = xpvav;
- xnv = (NV*) ptr;
- xnvend = &xnv[1008 / 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_allocated) - 1];
+ PL_xpvav_root = ++xpvav;
+ while (xpvav < xpvavend) {
+ *((xpvav_allocated**)xpvav) = xpvav + 1;
+ xpvav++;
}
- *(NV**)xnv = 0;
+ *((xpvav_allocated**)xpvav) = 0;
}
-/* grab a new struct xrv from the free list, allocating more if necessary */
+/* allocate another arena's worth of struct xpvhv */
-STATIC XRV*
-S_new_xrv(pTHX)
+STATIC void
+S_more_xpvhv(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;
+ xpvhv_allocated* xpvhv;
+ xpvhv_allocated* xpvhvend;
+ New(718, xpvhv, PERL_ARENA_SIZE/sizeof(xpvhv_allocated),
+ xpvhv_allocated);
+ *((xpvhv_allocated**)xpvhv) = PL_xpvhv_arenaroot;
+ PL_xpvhv_arenaroot = xpvhv;
+
+ xpvhvend = &xpvhv[PERL_ARENA_SIZE / sizeof(xpvhv_allocated) - 1];
+ PL_xpvhv_root = ++xpvhv;
+ while (xpvhv < xpvhvend) {
+ *((xpvhv_allocated**)xpvhv) = xpvhv + 1;
+ xpvhv++;
+ }
+ *((xpvhv_allocated**)xpvhv) = 0;
}
-/* return a struct xrv to the free list */
+/* allocate another arena's worth of struct xpvmg */
STATIC void
-S_del_xrv(pTHX_ XRV *p)
+S_more_xpvmg(pTHX)
{
- LOCK_SV_MUTEX;
- p->xrv_rv = (SV*)PL_xrv_root;
- PL_xrv_root = p;
- UNLOCK_SV_MUTEX;
+ 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;
}
-/* allocate another arena's worth of struct xrv */
+/* allocate another arena's worth of struct xpvgv */
STATIC void
-S_more_xrv(pTHX)
+S_more_xpvgv(pTHX)
{
- register XRV* xrv;
- register XRV* xrvend;
- XPV *ptr;
- New(712, ptr, 1008/sizeof(XPV), XPV);
- ptr->xpv_pv = (char*)PL_xrv_arenaroot;
- PL_xrv_arenaroot = ptr;
+ XPVGV* xpvgv;
+ XPVGV* xpvgvend;
+ New(720, xpvgv, PERL_ARENA_SIZE/sizeof(XPVGV), XPVGV);
+ *((XPVGV**)xpvgv) = PL_xpvgv_arenaroot;
+ PL_xpvgv_arenaroot = xpvgv;
- xrv = (XRV*) ptr;
- xrvend = &xrv[1008 / sizeof(XRV) - 1];
- xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
- PL_xrv_root = xrv;
- while (xrv < xrvend) {
- xrv->xrv_rv = (SV*)(xrv + 1);
- xrv++;
+ xpvgvend = &xpvgv[PERL_ARENA_SIZE / sizeof(XPVGV) - 1];
+ PL_xpvgv_root = ++xpvgv;
+ while (xpvgv < xpvgvend) {
+ *((XPVGV**)xpvgv) = xpvgv + 1;
+ xpvgv++;
}
- xrv->xrv_rv = 0;
+ *((XPVGV**)xpvgv) = 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**)xpvlv) = PL_xpvlv_arenaroot;
+ PL_xpvlv_arenaroot = xpvlv;
+
+ xpvlvend = &xpvlv[PERL_ARENA_SIZE / sizeof(XPVLV) - 1];
+ PL_xpvlv_root = ++xpvlv;
+ while (xpvlv < xpvlvend) {
+ *((XPVLV**)xpvlv) = xpvlv + 1;
+ xpvlv++;
+ }
+ *((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 */
STATIC XPV*
S_new_xpv(pTHX)
{
- XPV* xpv;
+ xpv_allocated* 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_allocated**)xpv;
UNLOCK_SV_MUTEX;
- return xpv;
+ /* If xpv_allocated is the same structure as XPV then the two OFFSETs
+ sum to zero, and the pointer is unchanged. If the allocated structure
+ is smaller (no initial IV actually allocated) then the net effect is
+ to subtract the size of the IV from the pointer, to return a new pointer
+ as if an initial IV were actually allocated. */
+ return (XPV*)((char*)xpv - STRUCT_OFFSET(XPV, xpv_cur)
+ + STRUCT_OFFSET(xpv_allocated, xpv_cur));
}
/* return a struct xpv to the free list */
STATIC void
S_del_xpv(pTHX_ XPV *p)
{
+ xpv_allocated* xpv
+ = (xpv_allocated*)((char*)(p) + STRUCT_OFFSET(XPV, xpv_cur)
+ - STRUCT_OFFSET(xpv_allocated, xpv_cur));
LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpv_root;
- PL_xpv_root = p;
+ *(xpv_allocated**)xpv = PL_xpv_root;
+ PL_xpv_root = xpv;
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, 1008/sizeof(XPV), XPV);
- xpv->xpv_pv = (char*)PL_xpv_arenaroot;
- PL_xpv_arenaroot = xpv;
-
- xpvend = &xpv[1008 / 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*
S_new_xpviv(pTHX)
{
- XPVIV* xpviv;
+ xpviv_allocated* 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_allocated**)xpviv;
UNLOCK_SV_MUTEX;
- return xpviv;
+ /* If xpviv_allocated is the same structure as XPVIV then the two OFFSETs
+ sum to zero, and the pointer is unchanged. If the allocated structure
+ is smaller (no initial IV actually allocated) then the net effect is
+ to subtract the size of the IV from the pointer, to return a new pointer
+ as if an initial IV were actually allocated. */
+ return (XPVIV*)((char*)xpviv - STRUCT_OFFSET(XPVIV, xpv_cur)
+ + STRUCT_OFFSET(xpviv_allocated, xpv_cur));
}
/* return a struct xpviv to the free list */
STATIC void
S_del_xpviv(pTHX_ XPVIV *p)
{
+ xpviv_allocated* xpviv
+ = (xpviv_allocated*)((char*)(p) + STRUCT_OFFSET(XPVIV, xpv_cur)
+ - STRUCT_OFFSET(xpviv_allocated, xpv_cur));
LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpviv_root;
- PL_xpviv_root = p;
+ *(xpviv_allocated**)xpviv = PL_xpviv_root;
+ PL_xpviv_root = xpviv;
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, 1008/sizeof(XPVIV), XPVIV);
- xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
- PL_xpviv_arenaroot = xpviv;
-
- xpvivend = &xpviv[1008 / 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, 1008/sizeof(XPVNV), XPVNV);
- xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
- PL_xpvnv_arenaroot = xpvnv;
-
- xpvnvend = &xpvnv[1008 / 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, 1008/sizeof(XPVCV), XPVCV);
- xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
- PL_xpvcv_arenaroot = xpvcv;
-
- xpvcvend = &xpvcv[1008 / 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*
S_new_xpvav(pTHX)
{
- XPVAV* xpvav;
+ xpvav_allocated* 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_allocated**)xpvav;
UNLOCK_SV_MUTEX;
- return xpvav;
+ return (XPVAV*)((char*)xpvav - STRUCT_OFFSET(XPVAV, xav_fill)
+ + STRUCT_OFFSET(xpvav_allocated, xav_fill));
}
/* return a struct xpvav to the free list */
STATIC void
S_del_xpvav(pTHX_ XPVAV *p)
{
+ xpvav_allocated* xpvav
+ = (xpvav_allocated*)((char*)(p) + STRUCT_OFFSET(XPVAV, xav_fill)
+ - STRUCT_OFFSET(xpvav_allocated, xav_fill));
LOCK_SV_MUTEX;
- p->xav_array = (char*)PL_xpvav_root;
- PL_xpvav_root = p;
+ *(xpvav_allocated**)xpvav = PL_xpvav_root;
+ PL_xpvav_root = xpvav;
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, 1008/sizeof(XPVAV), XPVAV);
- xpvav->xav_array = (char*)PL_xpvav_arenaroot;
- PL_xpvav_arenaroot = xpvav;
-
- xpvavend = &xpvav[1008 / 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*
S_new_xpvhv(pTHX)
{
- XPVHV* xpvhv;
+ xpvhv_allocated* 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_allocated**)xpvhv;
UNLOCK_SV_MUTEX;
- return xpvhv;
+ return (XPVHV*)((char*)xpvhv - STRUCT_OFFSET(XPVHV, xhv_fill)
+ + STRUCT_OFFSET(xpvhv_allocated, xhv_fill));
}
/* return a struct xpvhv to the free list */
STATIC void
S_del_xpvhv(pTHX_ XPVHV *p)
{
+ xpvhv_allocated* xpvhv
+ = (xpvhv_allocated*)((char*)(p) + STRUCT_OFFSET(XPVHV, xhv_fill)
+ - STRUCT_OFFSET(xpvhv_allocated, xhv_fill));
LOCK_SV_MUTEX;
- p->xhv_array = (char*)PL_xpvhv_root;
- PL_xpvhv_root = p;
+ *(xpvhv_allocated**)xpvhv = PL_xpvhv_root;
+ PL_xpvhv_root = xpvhv;
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, 1008/sizeof(XPVHV), XPVHV);
- xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
- PL_xpvhv_arenaroot = xpvhv;
-
- xpvhvend = &xpvhv[1008 / 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, 1008/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[1008 / 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, 1008/sizeof(XPVLV), XPVLV);
- xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
- PL_xpvlv_arenaroot = xpvlv;
-
- xpvlvend = &xpvlv[1008 / 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, 1008/sizeof(XPVBM), XPVBM);
- xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
- PL_xpvbm_arenaroot = xpvbm;
-
- xpvbmend = &xpvbm[1008 / 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)
if (SvTYPE(sv) == mt)
return TRUE;
- if (mt < SVt_PVIV)
- (void)SvOOK_off(sv);
-
pv = NULL;
cur = 0;
len = 0;
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);
del_XPVNV(SvANY(sv));
break;
case SVt_PVMG:
+ /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
+ 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.svu_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.svu_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) {
AvMAX(sv) = -1;
AvFILLp(sv) = -1;
AvALLOC(sv) = 0;
- AvARYLEN(sv)= 0;
- AvFLAGS(sv) = AVf_REAL;
- SvIV_set(sv, 0);
- SvNV_set(sv, 0.0);
+ AvREAL_only(sv);
}
/* to here. */
- if (pv)
- Safefree(pv);
+ /* XXX? Only SVt_NULL is ever upgraded to AV or HV? */
+ assert(!pv);
+ /* FIXME. Should be able to remove all this if()... if the above
+ assertion is genuinely always true. */
+ if(SvOOK(sv)) {
+ pv -= iv;
+ SvFLAGS(sv) &= ~SVf_OOK;
+ }
+ Safefree(pv);
SvPV_set(sv, (char*)0);
SvMAGIC_set(sv, magic);
SvSTASH_set(sv, stash);
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_const(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_const(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
return SvNVX(sv);
if (SvPOKp(sv) && SvLEN(sv)) {
if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
- !grok_number(SvPVX(sv), SvCUR(sv), NULL))
+ !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
not_a_number(sv);
return Atof(SvPVX(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);
if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
not_a_number(sv);
#ifdef NV_PRESERVES_UV
S_asUV(pTHX_ SV *sv)
{
UV value;
- int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
+ const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_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));
}
return SvPVX(tsv);
}
else {
+ dVAR;
STRLEN len;
const char *t;
if (SvPOKp(sv)) {
register XPV* Xpvtmp;
if ((Xpvtmp = (XPV*)SvANY(sv)) &&
- (*Xpvtmp->xpv_pv > '0' ||
+ (*sv->sv_u.svu_pv > '0' ||
Xpvtmp->xpv_cur > 1 ||
- (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
+ (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
return 1;
else
return 0;
STRLEN
Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
{
- U8 *s, *t, *e;
- int hibit = 0;
-
if (sv == &PL_sv_undef)
return 0;
if (!SvPOK(sv)) {
if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
sv_recode_to_utf8(sv, PL_encoding);
else { /* Assume Latin-1/EBCDIC */
- /* This function could be much more efficient if we
- * had a FLAG in SVs to signal if there are any hibit
- * chars in the PV. Given that there isn't such a flag
- * make the loop as fast as possible. */
- s = (U8 *) SvPVX(sv);
- e = (U8 *) SvEND(sv);
- t = s;
- while (t < e) {
- U8 ch = *t++;
- if ((hibit = !NATIVE_IS_INVARIANT(ch)))
- break;
- }
- if (hibit) {
- STRLEN len;
- (void)SvOOK_off(sv);
- s = (U8*)SvPVX(sv);
- len = SvCUR(sv) + 1; /* Plus the \0 */
- SvPV_set(sv, (char*)bytes_to_utf8((U8*)s, &len));
- SvCUR_set(sv, len - 1);
- if (SvLEN(sv) != 0)
- Safefree(s); /* No longer using what was there before. */
- SvLEN_set(sv, len); /* No longer know the real size. */
- }
- /* Mark as UTF-8 even if no hibit - saves scanning loop */
- SvUTF8_on(sv);
+ /* This function could be much more efficient if we
+ * had a FLAG in SVs to signal if there are any hibit
+ * chars in the PV. Given that there isn't such a flag
+ * make the loop as fast as possible. */
+ U8 *s = (U8 *) SvPVX(sv);
+ U8 *e = (U8 *) SvEND(sv);
+ U8 *t = s;
+ int hibit = 0;
+
+ while (t < e) {
+ U8 ch = *t++;
+ if ((hibit = !NATIVE_IS_INVARIANT(ch)))
+ break;
+ }
+ if (hibit) {
+ STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
+ s = bytes_to_utf8((U8*)s, &len);
+
+ SvPV_free(sv); /* No longer using what was there before. */
+
+ SvPV_set(sv, (char*)s);
+ SvCUR_set(sv, len - 1);
+ SvLEN_set(sv, len); /* No longer know the real size. */
+ }
+ /* Mark as UTF-8 even if no hibit - saves scanning loop */
+ SvUTF8_on(sv);
}
return SvCUR(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)) {
CvCONST(cv)
? "Constant subroutine %s::%s redefined"
: "Subroutine %s::%s redefined",
- HvNAME(GvSTASH((GV*)dstr)),
+ HvNAME_get(GvSTASH((GV*)dstr)),
GvENAME((GV*)dstr));
}
}
return;
}
if (SvPVX(dstr)) {
- (void)SvOOK_off(dstr); /* backoff */
- if (SvLEN(dstr))
- Safefree(SvPVX(dstr));
+ SvPV_free(dstr);
SvLEN_set(dstr, 0);
SvCUR_set(dstr, 0);
}
}
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)SvOK_off(sv);
return;
}
- (void)SvOOK_off(sv);
- if (SvPVX(sv) && SvLEN(sv))
- Safefree(SvPVX(sv));
+ if (SvPVX(sv))
+ SvPV_free(sv);
Renew(ptr, len+1, char);
SvPV_set(sv, ptr);
SvCUR_set(sv, len);
*/
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_arylen_p:
+ case PERL_MAGIC_rhash:
+ case PERL_MAGIC_symtab:
case PERL_MAGIC_vstring:
vtable = 0;
break;
}
/* Rest of work is done else where */
- mg = sv_magicext(sv,obj,how,vtable,name,namlen);
+ mg = sv_magicext(sv,obj,how,(MGVTBL*)vtable,name,namlen);
switch (how) {
case PERL_MAGIC_taint:
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.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
+ else if (SvTYPE(sv) == SVt_RV) {
+ SvANY(sv) = &sv->sv_u.svu_rv;
+ }
+
#ifdef PERL_COPY_ON_WRITE
if (SvIsCOW_normal(nsv)) {
void
Perl_sv_clear(pTHX_ register SV *sv)
{
+ dVAR;
HV* stash;
assert(sv);
assert(SvREFCNT(sv) == 0);
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_PVNV:
case SVt_PVIV:
freescalar:
- SvOOK_off(sv);
+ /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
+ if (SvOOK(sv)) {
+ SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
+ /* Don't even bother with turning off the OOK flag. */
+ }
/* FALL THROUGH */
case SVt_PV:
case SVt_RV:
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));
void
Perl_sv_free(pTHX_ SV *sv)
{
+ dVAR;
if (!sv)
return;
if (SvREFCNT(sv) == 0) {
void
Perl_sv_free2(pTHX_ SV *sv)
{
+ dVAR;
#ifdef DEBUGGING
if (SvTEMP(sv)) {
if (ckWARN_d(WARN_DEBUGGING))
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;
if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
if (!*mgp)
- *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
+ *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
assert(*mgp);
if ((*mgp)->mg_ptr)
}
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));
}
else
{
/*The big, slow, and stupid way. */
-
- /* Any stack-challenged places. */
-#if defined(EPOC)
- /* EPOC: need to work around SDK features. *
- * On WINS: MS VC5 generates calls to _chkstk, *
- * if a "large" stack frame is allocated. *
- * gcc on MARM does not generate calls like these. */
-# define USEHEAPINSTEADOFSTACK
-#endif
-
-#ifdef USEHEAPINSTEADOFSTACK
+#ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
STDCHAR *buf = 0;
New(0, buf, 8192, STDCHAR);
assert(buf);
goto screamer2;
}
-#ifdef USEHEAPINSTEADOFSTACK
+#ifdef USE_HEAP_INSTEAD_OF_STACK
Safefree(buf);
#endif
}
/* Got to punt this as an integer if needs be, but we don't issue
warnings. Probably ought to make the sv_iv_please() that does
the conversion if possible, and silently. */
- int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
+ const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
/* Need to try really hard to see if it's an integer.
9.22337203685478e+18 is an integer.
}
#ifdef PERL_PRESERVE_IVUV
{
- int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
+ const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
/* Need to try really hard to see if it's an integer.
9.22337203685478e+18 is an integer.
SV *
Perl_sv_2mortal(pTHX_ register SV *sv)
{
+ dVAR;
if (!sv)
return sv;
if (SvREADONLY(sv) && SvIMMORTAL(sv))
void
Perl_sv_reset(pTHX_ register const char *s, HV *stash)
{
+ dVAR;
register HE *entry;
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
CV *
Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
{
+ dVAR;
GV *gv = Nullgv;
CV *cv = Nullcv;
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.svu_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;
if (SvTYPE(rv) < SVt_RV)
sv_upgrade(rv, SVt_RV);
else if (SvTYPE(rv) > SVt_RV) {
- SvOOK_off(rv);
- if (SvPVX(rv) && SvLEN(rv))
- Safefree(SvPVX(rv));
+ SvPV_free(rv);
SvCUR_set(rv, 0);
SvLEN_set(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 char nullstr[] = "(null)";
+ static const char nullstr[] = "(null)";
SV *argsv = Nullsv;
bool has_utf8; /* has the result utf8? */
bool pat_utf8; /* the pattern is in utf8? */
/* 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
#endif
elen = strlen(eptr);
else {
- eptr = nullstr;
+ eptr = (char *)nullstr;
elen = sizeof nullstr - 1;
}
}
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);
REGEXP *
Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
{
+ dVAR;
REGEXP *ret;
int i, len, npar;
struct reg_substr_datum *s;
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)
# define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
#endif
+
+
+STATIC void
+S_more_pte(pTHX)
+{
+ 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;
+
+ pteend = &pte[PERL_ARENA_SIZE / sizeof(struct ptr_tbl_ent) - 1];
+ PL_pte_root = ++pte;
+ while (pte < pteend) {
+ pte->next = pte + 1;
+ pte++;
+ }
+ pte->next = 0;
+}
+
+STATIC struct ptr_tbl_ent*
+S_new_pte(pTHX)
+{
+ struct ptr_tbl_ent* pte;
+ if (!PL_pte_root)
+ S_more_pte(aTHX);
+ pte = PL_pte_root;
+ PL_pte_root = pte->next;
+ return pte;
+}
+
+STATIC void
+S_del_pte(pTHX_ struct ptr_tbl_ent*p)
+{
+ p->next = PL_pte_root;
+ PL_pte_root = p;
+}
+
/* map an existing pointer using a table */
void *
Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
{
PTR_TBL_ENT_t *tblent;
- UV hash = PTR_TABLE_HASH(sv);
+ const UV hash = PTR_TABLE_HASH(sv);
assert(tbl);
tblent = tbl->tbl_ary[hash & tbl->tbl_max];
for (; tblent; tblent = tblent->next) {
/* XXX this may be pessimal on platforms where pointers aren't good
* hash values e.g. if they grow faster in the most significant
* bits */
- UV hash = PTR_TABLE_HASH(oldv);
+ const UV hash = PTR_TABLE_HASH(oldv);
bool empty = 1;
assert(tbl);
return;
}
}
- Newz(0, tblent, 1, PTR_TBL_ENT_t);
+ tblent = S_new_pte(aTHX);
tblent->oldval = oldv;
tblent->newval = newv;
tblent->next = *otblent;
Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
{
PTR_TBL_ENT_t **ary = tbl->tbl_ary;
- UV oldsize = tbl->tbl_max + 1;
+ const UV oldsize = tbl->tbl_max + 1;
UV newsize = oldsize * 2;
UV i;
{
register PTR_TBL_ENT_t **array;
register PTR_TBL_ENT_t *entry;
- register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
UV riter = 0;
UV max;
for (;;) {
if (entry) {
- oentry = entry;
+ PTR_TBL_ENT_t *oentry = entry;
entry = entry->next;
- Safefree(oentry);
+ S_del_pte(aTHX_ oentry);
}
if (!entry) {
if (++riter > max) {
Safefree(tbl);
}
-#ifdef DEBUGGING
-char *PL_watch_pvx;
-#endif
-
/* attempt to make everything in the typeglob readonly */
STATIC SV *
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;
}
SV *
Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
{
+ dVAR;
SV *dstr;
if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
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.svu_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.svu_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;
}
SvANY(dstr) = new_XPVAV();
SvCUR_set(dstr, SvCUR(sstr));
SvLEN_set(dstr, SvLEN(sstr));
- SvIV_set(dstr, SvIVX(sstr));
- SvNV_set(dstr, SvNVX(sstr));
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;
SvANY(dstr) = new_XPVHV();
SvCUR_set(dstr, SvCUR(sstr));
SvLEN_set(dstr, SvLEN(sstr));
- SvIV_set(dstr, SvIVX(sstr));
- SvNV_set(dstr, SvNVX(sstr));
+ HvTOTALKEYS(dstr) = HvTOTALKEYS(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;
+ {
+ struct xpvhv_aux *aux = ((XPVHV *)SvANY(sstr))->xhv_aux;
+ HEK *hvname = 0;
+
+ if (aux) {
+ I32 riter = aux->xhv_riter;
+
+ hvname = aux->xhv_name;
+ if (hvname || riter != -1) {
+ struct xpvhv_aux *d_aux;
+
+ New(0, d_aux, 1, struct xpvhv_aux);
+
+ d_aux->xhv_riter = riter;
+ d_aux->xhv_eiter = 0;
+ d_aux->xhv_name = hvname ? hek_dup(hvname, param) : hvname;
+
+ ((XPVHV *)SvANY(dstr))->xhv_aux = d_aux;
+ } 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;
+ else {
+ ((XPVHV *)SvANY(dstr))->xhv_aux = 0;
+ }
+ 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);
+ STRLEN len = HvNAMELEN_get((HV*)sv);
SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
if (cloner && GvCV(cloner)) {
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVpv(HvNAME((HV*)sv), 0)));
+ XPUSHs(sv_2mortal(newSVpvn(hvname, len)));
PUTBACK;
call_sv((SV*)GvCV(cloner), G_SCALAR);
SPAGAIN;
PerlInterpreter *
perl_clone(PerlInterpreter *proto_perl, UV flags)
{
+ dVAR;
#ifdef PERL_IMPLICIT_SYS
/* perlhost.h so we need to call into it
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;
PL_xpvbm_root = NULL;
PL_he_arenaroot = NULL;
PL_he_root = NULL;
+#if defined(USE_ITHREADS)
+ PL_pte_arenaroot = NULL;
+ PL_pte_root = NULL;
+#endif
PL_nice_chunk = NULL;
PL_nice_chunk_size = 0;
PL_sv_count = 0;
PL_debug = proto_perl->Idebug;
+ PL_hash_seed = proto_perl->Ihash_seed;
+ PL_rehash_seed = proto_perl->Irehash_seed;
+
#ifdef USE_REENTRANT_API
/* XXX: things like -Dm will segfault here in perlio, but doing
* PERL_SET_CONTEXT(proto_perl);
/* create SV map for pointer relocation */
PL_ptr_table = ptr_table_new();
+ /* and one for finding shared hash keys quickly */
+ PL_shared_hek_table = ptr_table_new();
/* initialize these special pointers as early as possible */
SvANY(&PL_sv_undef) = NULL;
/* create (a non-shared!) shared string table */
PL_strtab = newHV();
HvSHAREKEYS_off(PL_strtab);
- hv_ksplit(PL_strtab, 512);
+ hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
PL_compiling = proto_perl->Icompiling;
/* 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));
PL_glob_index = proto_perl->Iglob_index;
PL_srand_called = proto_perl->Isrand_called;
- PL_hash_seed = proto_perl->Ihash_seed;
- PL_rehash_seed = proto_perl->Irehash_seed;
PL_uudmap['M'] = 0; /* reinits on demand */
PL_bitcount = Nullch; /* reinits on demand */
if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
+ ptr_table_free(PL_shared_hek_table);
+ PL_shared_hek_table = NULL;
}
/* Call the ->CLONE method, if it exists, for each of the stashes
ENTER;
SAVETMPS;
PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
+ XPUSHs(sv_2mortal(newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash))));
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;
}
char *
Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
{
+ dVAR;
if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
SV *uni;
STRLEN len;
Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
SV *ssv, int *offset, char *tstr, int tlen)
{
+ dVAR;
bool ret = FALSE;
if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
SV *offsv;
* indent-tabs-mode: t
* End:
*
- * vim: shiftwidth=4:
-*/
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
projects / p5sagit/p5-mst-13.2.git / blobdiff