pointer to the body (struct xrv, xpv, xpviv...), which contains fields
specific to each type.
-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.
+In all but the most memory-paranoid configuations (ex: PURIFY), this
+allocation is done using arenas, which by default are approximately 4K
+chunks of memory parcelled up into N heads or bodies (of same size).
+Sv-bodies are allocated by their sv-type, guaranteeing size
+consistency needed to allocate safely from arrays.
+
+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.
The following global variables are associated with arenas:
PL_sv_arenaroot pointer to list of SV arenas
PL_sv_root pointer to list of free SV structures
- PL_foo_arenaroot pointer to list of foo arenas,
- PL_foo_root pointer to list of free foo bodies
- ... for foo in xiv, xnv, xrv, xpv etc.
+ PL_body_arenaroots[] array of pointers to list of arenas, 1 per svtype
+ PL_body_roots[] array of pointers to list of free bodies of svtype
+ arrays are indexed by the svtype needed
-Note that some of the larger and more rarely used body types (eg xpvio)
-are not allocated using arenas, but are instead just malloc()/free()ed as
-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. The size of arenas can be changed from
-the default by setting PERL_ARENA_SIZE appropriately at compile time.
+Note that some of the larger and more rarely used body types (eg
+xpvio) are not allocated using arenas, but are instead just
+malloc()/free()ed as required.
+
+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.
+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.
of zero. called repeatedly from perl_destruct()
until there are no SVs left.
-=head2 Summary
+=head2 Arena allocator API Summary
Private API to rest of sv.c
}
#ifdef DEBUG_LEAKING_SCALARS
-# ifdef NETWARE
-# define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file)
-# else
-# define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file)
-# endif
+# define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
#else
# define FREE_SV_DEBUG_FILE(sv)
#endif
+#ifdef PERL_POISON
+# define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
+/* Whilst I'd love to do this, it seems that things like to check on
+ unreferenced scalars
+# define POSION_SV_HEAD(sv) Poison(sv, 1, struct STRUCT_SV)
+*/
+# define POSION_SV_HEAD(sv) Poison(&SvANY(sv), 1, void *), \
+ Poison(&SvREFCNT(sv), 1, U32)
+#else
+# define SvARENA_CHAIN(sv) SvANY(sv)
+# define POSION_SV_HEAD(sv)
+#endif
+
#define plant_SV(p) \
STMT_START { \
FREE_SV_DEBUG_FILE(p); \
- SvANY(p) = (void *)PL_sv_root; \
+ POSION_SV_HEAD(p); \
+ SvARENA_CHAIN(p) = (void *)PL_sv_root; \
SvFLAGS(p) = SVTYPEMASK; \
PL_sv_root = (p); \
--PL_sv_count; \
#define uproot_SV(p) \
STMT_START { \
(p) = PL_sv_root; \
- PL_sv_root = (SV*)SvANY(p); \
+ PL_sv_root = (SV*)SvARENA_CHAIN(p); \
++PL_sv_count; \
} STMT_END
(PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
sv->sv_debug_inpad = 0;
sv->sv_debug_cloned = 0;
-# ifdef NETWARE
sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
-# else
- sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
-# endif
return sv;
}
svend = &sva[SvREFCNT(sva) - 1];
sv = sva + 1;
while (sv < svend) {
- SvANY(sv) = (void *)(SV*)(sv + 1);
+ SvARENA_CHAIN(sv) = (void *)(SV*)(sv + 1);
#ifdef DEBUGGING
SvREFCNT(sv) = 0;
#endif
SvFLAGS(sv) = SVTYPEMASK;
sv++;
}
- SvANY(sv) = 0;
+ SvARENA_CHAIN(sv) = 0;
#ifdef DEBUGGING
SvREFCNT(sv) = 0;
#endif
static void
do_clean_objs(pTHX_ SV *ref)
{
- SV* target;
-
- if (SvROK(ref) && SvOBJECT(target = SvRV(ref))) {
- DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
- if (SvWEAKREF(ref)) {
- sv_del_backref(target, ref);
- SvWEAKREF_off(ref);
- SvRV_set(ref, NULL);
- } else {
- SvROK_off(ref);
- SvRV_set(ref, NULL);
- SvREFCNT_dec(target);
+ if (SvROK(ref)) {
+ SV * const target = SvRV(ref);
+ if (SvOBJECT(target)) {
+ DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
+ if (SvWEAKREF(ref)) {
+ sv_del_backref(target, ref);
+ SvWEAKREF_off(ref);
+ SvRV_set(ref, NULL);
+ } else {
+ SvROK_off(ref);
+ SvRV_set(ref, NULL);
+ SvREFCNT_dec(target);
+ }
}
}
=cut
*/
-
#define free_arena(name) \
STMT_START { \
S_free_arena(aTHX_ (void**) PL_ ## name ## _arenaroot); \
{
SV* sva;
SV* svanext;
+ int i;
/* Free arenas here, but be careful about fake ones. (We assume
contiguity of the fake ones with the corresponding real ones.) */
if (!SvFAKE(sva))
Safefree(sva);
}
-
- free_arena(xnv);
- free_arena(xpv);
- free_arena(xpviv);
- free_arena(xpvnv);
- free_arena(xpvcv);
- free_arena(xpvav);
- free_arena(xpvhv);
- free_arena(xpvmg);
- free_arena(xpvgv);
- free_arena(xpvlv);
- free_arena(xpvbm);
+
+ for (i=0; i<SVt_LAST; i++) {
+ S_free_arena(aTHX_ (void**) PL_body_arenaroots[i]);
+ PL_body_arenaroots[i] = 0;
+ PL_body_roots[i] = 0;
+ }
+
free_arena(he);
#if defined(USE_ITHREADS)
free_arena(pte);
SV * const name = sv_newmortal();
if (gv) {
+ char buffer[2];
+ buffer[0] = gvtype;
+ buffer[1] = 0;
- /* simulate gv_fullname4(), but add literal '^' for $^FOO names
- * XXX get rid of all this if gv_fullnameX() ever supports this
- * directly */
-
- const char *p;
- HV * const hv = GvSTASH(gv);
- if (!hv)
- p = "???";
- else if (!(p=HvNAME_get(hv)))
- p = "__ANON__";
- if (strEQ(p, "main"))
- sv_setpvn(name, &gvtype, 1);
- else
- Perl_sv_setpvf(aTHX_ name, "%c%s::", gvtype, p);
+ /* as gv_fullname4(), but add literal '^' for $^FOO names */
- if (GvNAMELEN(gv)>= 1 &&
- ((unsigned int)*GvNAME(gv)) <= 26)
- { /* handle $^FOO */
- Perl_sv_catpvf(aTHX_ name,"^%c", *GvNAME(gv) + 'A' - 1);
- sv_catpvn(name,GvNAME(gv)+1,GvNAMELEN(gv)-1);
+ gv_fullname4(name, gv, buffer, 0);
+
+ if ((unsigned int)SvPVX(name)[1] <= 26) {
+ buffer[0] = '^';
+ buffer[1] = SvPVX(name)[1] + 'A' - 1;
+
+ /* Swap the 1 unprintable control character for the 2 byte pretty
+ version - ie substr($name, 1, 1) = $buffer; */
+ sv_insert(name, 1, 1, buffer, 2);
}
- else
- sv_catpvn(name,GvNAME(gv),GvNAMELEN(gv));
}
else {
U32 unused;
"", "", "");
}
+/*
+ Here are mid-level routines that manage the allocation of bodies out
+ of the various arenas. There are 5 kinds of arenas:
+
+ 1. SV-head arenas, which are discussed and handled above
+ 2. regular body arenas
+ 3. arenas for reduced-size bodies
+ 4. Hash-Entry arenas
+ 5. pte arenas (thread related)
+
+ Arena types 2 & 3 are chained by body-type off an array of
+ arena-root pointers, which is indexed by svtype. Some of the
+ larger/less used body types are malloced singly, since a large
+ unused block of them is wasteful. Also, several svtypes dont have
+ bodies; the data fits into the sv-head itself. The arena-root
+ pointer thus has a few unused root-pointers (which may be hijacked
+ later for arena types 4,5)
+
+ 3 differs from 2 as an optimization; some body types have several
+ unused fields in the front of the structure (which are kept in-place
+ for consistency). These bodies can be allocated in smaller chunks,
+ because the leading fields arent accessed. Pointers to such bodies
+ are decremented to point at the unused 'ghost' memory, knowing that
+ the pointers are used with offsets to the real memory.
+
+ HE, HEK arenas are managed separately, with separate code, but may
+ be merge-able later..
+
+ PTE arenas are not sv-bodies, but they share these mid-level
+ mechanics, so are considered here. The new mid-level mechanics rely
+ on the sv_type of the body being allocated, so we just reserve one
+ of the unused body-slots for PTEs, then use it in those (2) PTE
+ contexts below (line ~10k)
+*/
+#define PTE_SVSLOT SVt_IV
+
STATIC void *
-S_more_bodies (pTHX_ void **arena_root, void **root, size_t size)
+S_more_bodies (pTHX_ size_t size, svtype sv_type)
{
+ void **arena_root = &PL_body_arenaroots[sv_type];
+ void **root = &PL_body_roots[sv_type];
char *start;
const char *end;
- const size_t count = PERL_ARENA_SIZE/size;
+ const size_t count = PERL_ARENA_SIZE / size;
+
Newx(start, count*size, char);
*((void **) start) = *arena_root;
*arena_root = (void *)start;
/* 1st, the inline version */
-#define new_body_inline(xpv, arena_root, root, size) \
+#define new_body_inline(xpv, root, size, sv_type) \
STMT_START { \
LOCK_SV_MUTEX; \
xpv = *((void **)(root)) \
- ? *((void **)(root)) : S_more_bodies(aTHX_ arena_root, root, size); \
+ ? *((void **)(root)) : S_more_bodies(aTHX_ size, sv_type); \
*(root) = *(void**)(xpv); \
UNLOCK_SV_MUTEX; \
} STMT_END
/* now use the inline version in the proper function */
STATIC void *
-S_new_body(pTHX_ void **arena_root, void **root, size_t size)
+S_new_body(pTHX_ size_t size, svtype sv_type)
{
void *xpv;
- new_body_inline(xpv, arena_root, root, size);
+ new_body_inline(xpv, &PL_body_roots[sv_type], size, sv_type);
return xpv;
}
UNLOCK_SV_MUTEX; \
} STMT_END
-/* Conventionally we simply malloc() a big block of memory, then divide it
- up into lots of the thing that we're allocating.
-
- This macro will expand to call to S_new_body. So for XPVBM (with ithreads),
- it would become
-
- S_new_body(my_perl, (void**)&(my_perl->Ixpvbm_arenaroot),
- (void**)&(my_perl->Ixpvbm_root), sizeof(XPVBM), 0)
-*/
-
-#define new_body_type(TYPE,lctype) \
- S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \
- (void**)&PL_ ## lctype ## _root, \
- sizeof(TYPE))
-
-#define del_body_type(p,TYPE,lctype) \
- del_body((void*)p, (void**)&PL_ ## lctype ## _root)
+/*
+ Revisiting type 3 arenas, there are 4 body-types which have some
+ members that are never accessed. They are XPV, XPVIV, XPVAV,
+ XPVHV, which have corresponding types: xpv_allocated,
+ xpviv_allocated, xpvav_allocated, xpvhv_allocated,
-/* But for some types, we cheat. The type starts with some members that are
- never accessed. So we allocate the substructure, starting at the first used
- member, then adjust the pointer back in memory by the size of the bit not
- allocated, so it's as if we allocated the full structure.
- (But things will all go boom if you write to the part that is "not there",
- because you'll be overwriting the last members of the preceding structure
- in memory.)
+ For these types, the arenas are carved up into *_allocated size
+ chunks, we thus avoid wasted memory for those unaccessed members.
+ When bodies are allocated, we adjust the pointer back in memory by
+ the size of the bit not allocated, so it's as if we allocated the
+ full structure. (But things will all go boom if you write to the
+ part that is "not there", because you'll be overwriting the last
+ members of the preceding structure in memory.)
We calculate the correction using the STRUCT_OFFSET macro. For example, if
xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero,
start of the structure. IV bodies don't need it either, because they are
no longer allocated. */
-#define new_body_allocated(TYPE,lctype,member) \
- (void*)((char*)S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \
- (void**)&PL_ ## lctype ## _root, \
- sizeof(lctype ## _allocated)) - \
- STRUCT_OFFSET(TYPE, member) \
- + STRUCT_OFFSET(lctype ## _allocated, member))
+/* The following 2 arrays hide the above details in a pair of
+ lookup-tables, allowing us to be body-type agnostic.
+
+ sizeof_body_by_svtype[] maps svtype to its body's allocated size.
+ offset_by_type[] maps svtype to the body-pointer adjustment needed
+
+ NB: elements in latter are 0 or <0, and are added during
+ allocation, and subtracted during deallocation. It may be clearer
+ to invert the values, and call it shrinkage_by_svtype.
+*/
+
+static int sizeof_body_by_svtype[] = {
+ 0, /* SVt_NULLs, SVt_IVs, SVt_NVs, SVt_RVs have no body */
+ 0,
+ sizeof(xpv_allocated), /* 8 bytes on 686 */
+ 0,
+ sizeof(xpv_allocated), /* 8 bytes on 686 */
+ sizeof(xpviv_allocated), /* 12 */
+ sizeof(XPVNV), /* 20 */
+ sizeof(XPVMG), /* 28 */
+ sizeof(XPVBM), /* 36 */
+ sizeof(XPVGV), /* 48 */
+ sizeof(XPVLV), /* 64 */
+ sizeof(xpvav_allocated), /* 20 */
+ sizeof(xpvhv_allocated), /* 20 */
+ sizeof(XPVCV), /* 76 */
+ sizeof(XPVFM), /* 80 */
+ sizeof(XPVIO) /* 84 */
+};
+#define SIZE_SVTYPES sizeof(sizeof_body_by_svtype)
+
+static int offset_by_svtype[] = {
+ 0,
+ 0,
+ 0,
+ 0,
+ STRUCT_OFFSET(xpv_allocated, xpv_cur) - STRUCT_OFFSET(XPV, xpv_cur),
+ STRUCT_OFFSET(xpviv_allocated, xpv_cur) - STRUCT_OFFSET(XPVIV, xpv_cur),
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ STRUCT_OFFSET(xpvav_allocated, xav_fill) - STRUCT_OFFSET(XPVAV, xav_fill),
+ STRUCT_OFFSET(xpvhv_allocated, xhv_fill) - STRUCT_OFFSET(XPVHV, xhv_fill),
+ 0,
+ 0,
+ 0,
+};
+#define SIZE_OFFSETS sizeof(sizeof_body_by_svtype)
+
+/* they better stay synchronized, but this doesnt do it.
+ #if SIZE_SVTYPES != SIZE_OFFSETS
+ #error "declaration problem: sizeof_body_by_svtype != sizeof(offset_by_svtype)"
+ #endif
+*/
+
+
+#define new_body_type(sv_type) \
+ S_new_body(aTHX_ sizeof_body_by_svtype[sv_type], sv_type) \
+ + offset_by_svtype[sv_type]
+
+#define del_body_type(p, sv_type) \
+ del_body(p, &PL_body_roots[sv_type])
-#define del_body_allocated(p,TYPE,lctype,member) \
- del_body((void*)((char*)p + STRUCT_OFFSET(TYPE, member) \
- - STRUCT_OFFSET(lctype ## _allocated, member)), \
- (void**)&PL_ ## lctype ## _root)
+#define new_body_allocated(sv_type) \
+ S_new_body(aTHX_ sizeof_body_by_svtype[sv_type], sv_type) \
+ + offset_by_svtype[sv_type]
+
+#define del_body_allocated(p, sv_type) \
+ del_body(p - offset_by_svtype[sv_type], &PL_body_roots[sv_type])
+
#define my_safemalloc(s) (void*)safemalloc(s)
#define my_safefree(p) safefree((char*)p)
#else /* !PURIFY */
-#define new_XNV() new_body_type(NV, xnv)
-#define del_XNV(p) del_body_type(p, NV, xnv)
+#define new_XNV() new_body_type(SVt_NV)
+#define del_XNV(p) del_body_type(p, SVt_NV)
-#define new_XPV() new_body_allocated(XPV, xpv, xpv_cur)
-#define del_XPV(p) del_body_allocated(p, XPV, xpv, xpv_cur)
+#define new_XPV() new_body_allocated(SVt_PV)
+#define del_XPV(p) del_body_allocated(p, SVt_PV)
-#define new_XPVIV() new_body_allocated(XPVIV, xpviv, xpv_cur)
-#define del_XPVIV(p) del_body_allocated(p, XPVIV, xpviv, xpv_cur)
+#define new_XPVIV() new_body_allocated(SVt_PVIV)
+#define del_XPVIV(p) del_body_allocated(p, SVt_PVIV)
-#define new_XPVNV() new_body_type(XPVNV, xpvnv)
-#define del_XPVNV(p) del_body_type(p, XPVNV, xpvnv)
+#define new_XPVNV() new_body_type(SVt_PVNV)
+#define del_XPVNV(p) del_body_type(p, SVt_PVNV)
-#define new_XPVCV() new_body_type(XPVCV, xpvcv)
-#define del_XPVCV(p) del_body_type(p, XPVCV, xpvcv)
+#define new_XPVCV() new_body_type(SVt_PVCV)
+#define del_XPVCV(p) del_body_type(p, SVt_PVCV)
-#define new_XPVAV() new_body_allocated(XPVAV, xpvav, xav_fill)
-#define del_XPVAV(p) del_body_allocated(p, XPVAV, xpvav, xav_fill)
+#define new_XPVAV() new_body_allocated(SVt_PVAV)
+#define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
-#define new_XPVHV() new_body_allocated(XPVHV, xpvhv, xhv_fill)
-#define del_XPVHV(p) del_body_allocated(p, XPVHV, xpvhv, xhv_fill)
+#define new_XPVHV() new_body_allocated(SVt_PVHV)
+#define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
-#define new_XPVMG() new_body_type(XPVMG, xpvmg)
-#define del_XPVMG(p) del_body_type(p, XPVMG, xpvmg)
+#define new_XPVMG() new_body_type(SVt_PVMG)
+#define del_XPVMG(p) del_body_type(p, SVt_PVMG)
-#define new_XPVGV() new_body_type(XPVGV, xpvgv)
-#define del_XPVGV(p) del_body_type(p, XPVGV, xpvgv)
+#define new_XPVGV() new_body_type(SVt_PVGV)
+#define del_XPVGV(p) del_body_type(p, SVt_PVGV)
-#define new_XPVLV() new_body_type(XPVLV, xpvlv)
-#define del_XPVLV(p) del_body_type(p, XPVLV, xpvlv)
+#define new_XPVLV() new_body_type(SVt_PVLV)
+#define del_XPVLV(p) del_body_type(p, SVt_PVLV)
-#define new_XPVBM() new_body_type(XPVBM, xpvbm)
-#define del_XPVBM(p) del_body_type(p, XPVBM, xpvbm)
+#define new_XPVBM() new_body_type(SVt_PVBM)
+#define del_XPVBM(p) del_body_type(p, SVt_PVBM)
#endif /* PURIFY */
+/* no arena for you! */
#define new_XPVFM() my_safemalloc(sizeof(XPVFM))
#define del_XPVFM(p) my_safefree(p)
#define new_XPVIO() my_safemalloc(sizeof(XPVIO))
#define del_XPVIO(p) my_safefree(p)
+
+
/*
=for apidoc sv_upgrade
old_body_length = sizeof(IV);
break;
case SVt_NV:
- old_body_arena = (void **) &PL_xnv_root;
+ old_body_arena = &PL_body_roots[SVt_NV];
old_body_length = sizeof(NV);
#ifndef NV_ZERO_IS_ALLBITS_ZERO
zero_nv = FALSE;
case SVt_RV:
break;
case SVt_PV:
- old_body_arena = (void **) &PL_xpv_root;
- old_body_offset = STRUCT_OFFSET(XPV, xpv_cur)
- - STRUCT_OFFSET(xpv_allocated, xpv_cur);
+ old_body_arena = &PL_body_roots[SVt_PV];
+ old_body_offset = - offset_by_svtype[SVt_PVIV];
old_body_length = STRUCT_OFFSET(XPV, xpv_len)
+ sizeof (((XPV*)SvANY(sv))->xpv_len)
- old_body_offset;
mt = SVt_PVNV;
break;
case SVt_PVIV:
- old_body_arena = (void **) &PL_xpviv_root;
- old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur)
- - STRUCT_OFFSET(xpviv_allocated, xpv_cur);
- old_body_length = STRUCT_OFFSET(XPVIV, xiv_u)
- + sizeof (((XPVIV*)SvANY(sv))->xiv_u)
- - old_body_offset;
+ old_body_arena = &PL_body_roots[SVt_PVIV];
+ old_body_offset = - offset_by_svtype[SVt_PVIV];
+ old_body_length = STRUCT_OFFSET(XPVIV, xiv_u);
+ old_body_length += sizeof (((XPVIV*)SvANY(sv))->xiv_u);
+ old_body_length -= old_body_offset;
break;
case SVt_PVNV:
- old_body_arena = (void **) &PL_xpvnv_root;
+ old_body_arena = &PL_body_roots[SVt_PVNV];
old_body_length = STRUCT_OFFSET(XPVNV, xiv_u)
+ sizeof (((XPVNV*)SvANY(sv))->xiv_u);
#ifndef NV_ZERO_IS_ALLBITS_ZERO
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);
- old_body_arena = (void **) &PL_xpvmg_root;
+ old_body_arena = &PL_body_roots[SVt_PVMG];
old_body_length = STRUCT_OFFSET(XPVMG, xmg_stash)
+ sizeof (((XPVMG*)SvANY(sv))->xmg_stash);
#ifndef NV_ZERO_IS_ALLBITS_ZERO
goto zero;
case SVt_PVBM:
- new_body_length = sizeof(XPVBM);
- new_body_arena = (void **) &PL_xpvbm_root;
- new_body_arenaroot = (void **) &PL_xpvbm_arenaroot;
- goto new_body;
case SVt_PVGV:
- new_body_length = sizeof(XPVGV);
- new_body_arena = (void **) &PL_xpvgv_root;
- new_body_arenaroot = (void **) &PL_xpvgv_arenaroot;
- goto new_body;
case SVt_PVCV:
- new_body_length = sizeof(XPVCV);
- new_body_arena = (void **) &PL_xpvcv_root;
- new_body_arenaroot = (void **) &PL_xpvcv_arenaroot;
- goto new_body;
case SVt_PVLV:
- new_body_length = sizeof(XPVLV);
- new_body_arena = (void **) &PL_xpvlv_root;
- new_body_arenaroot = (void **) &PL_xpvlv_arenaroot;
- goto new_body;
case SVt_PVMG:
- new_body_length = sizeof(XPVMG);
- new_body_arena = (void **) &PL_xpvmg_root;
- new_body_arenaroot = (void **) &PL_xpvmg_arenaroot;
- goto new_body;
case SVt_PVNV:
- new_body_length = sizeof(XPVNV);
- new_body_arena = (void **) &PL_xpvnv_root;
- new_body_arenaroot = (void **) &PL_xpvnv_arenaroot;
+ new_body_length = sizeof_body_by_svtype[mt];
+ new_body_arena = &PL_body_roots[mt];
+ new_body_arenaroot = &PL_body_arenaroots[mt];
goto new_body;
+
case SVt_PVIV:
- new_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur)
- - STRUCT_OFFSET(xpviv_allocated, xpv_cur);
+ new_body_offset = - offset_by_svtype[SVt_PVIV];
new_body_length = sizeof(XPVIV) - new_body_offset;
- new_body_arena = (void **) &PL_xpviv_root;
- new_body_arenaroot = (void **) &PL_xpviv_arenaroot;
+ new_body_arena = &PL_body_roots[SVt_PVIV];
+ new_body_arenaroot = &PL_body_arenaroots[SVt_PVIV];
/* XXX Is this still needed? Was it ever needed? Surely as there is
no route from NV to PVIV, NOK can never be true */
if (SvNIOK(sv))
SvNOK_off(sv);
goto new_body_no_NV;
case SVt_PV:
- new_body_offset = STRUCT_OFFSET(XPV, xpv_cur)
- - STRUCT_OFFSET(xpv_allocated, xpv_cur);
+ new_body_offset = - offset_by_svtype[SVt_PV];
new_body_length = sizeof(XPV) - new_body_offset;
- new_body_arena = (void **) &PL_xpv_root;
- new_body_arenaroot = (void **) &PL_xpv_arenaroot;
+ new_body_arena = &PL_body_roots[SVt_PV];
+ new_body_arenaroot = &PL_body_arenaroots[SVt_PV];
new_body_no_NV:
/* PV and PVIV don't have an NV slot. */
#ifndef NV_ZERO_IS_ALLBITS_ZERO
assert(new_body_length);
#ifndef PURIFY
/* This points to the start of the allocated area. */
- new_body_inline(new_body, new_body_arenaroot, new_body_arena,
- new_body_length);
+ new_body_inline(new_body, new_body_arena, new_body_length, mt);
#else
/* We always allocated the full length item with PURIFY */
new_body_length += new_body_offset;
pv = sv_uni_display(dsv, sv, 10, 0);
} else {
char *d = tmpbuf;
- char *limit = tmpbuf + sizeof(tmpbuf) - 8;
+ const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
/* each *s can expand to 4 chars + "...\0",
i.e. need room for 8 chars */
}
#endif /* !NV_PRESERVES_UV*/
-/* sv_2iv() is now a macro using Perl_sv_2iv_flags();
- * this function provided for binary compatibility only
- */
-
-IV
-Perl_sv_2iv(pTHX_ register SV *sv)
-{
- return sv_2iv_flags(sv, SV_GMAGIC);
-}
-
/*
=for apidoc sv_2iv_flags
}
if (SvTHINKFIRST(sv)) {
if (SvROK(sv)) {
- SV* tmpstr;
- if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
- (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
- return SvIV(tmpstr);
- return PTR2IV(SvRV(sv));
+ if (SvAMAGIC(sv)) {
+ SV * const tmpstr=AMG_CALLun(sv,numer);
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ return SvIV(tmpstr);
+ }
+ }
+ return PTR2IV(SvRV(sv));
}
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
}
-/* sv_2uv() is now a macro using Perl_sv_2uv_flags();
- * this function provided for binary compatibility only
- */
-
-UV
-Perl_sv_2uv(pTHX_ register SV *sv)
-{
- return sv_2uv_flags(sv, SV_GMAGIC);
-}
-
/*
=for apidoc sv_2uv_flags
return U_V(Atof(SvPVX_const(sv)));
}
-/*
-=for apidoc sv_2pv_nolen
-
-Like C<sv_2pv()>, but doesn't return the length too. You should usually
-use the macro wrapper C<SvPV_nolen(sv)> instead.
-=cut
-*/
-
-char *
-Perl_sv_2pv_nolen(pTHX_ register SV *sv)
-{
- return sv_2pv(sv, 0);
-}
-
/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
* UV as a string towards the end of buf, and return pointers to start and
* end of it.
S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
{
char *ptr = buf + TYPE_CHARS(UV);
- char *ebuf = ptr;
+ char * const ebuf = ptr;
int sign;
if (is_uv)
return ptr;
}
-/* sv_2pv() is now a macro using Perl_sv_2pv_flags();
- * this function provided for binary compatibility only
- */
-
-char *
-Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
-{
- return sv_2pv_flags(sv, lp, SV_GMAGIC);
-}
-
/*
=for apidoc sv_2pv_flags
SV *tsv, *origsv;
char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
char *tmpbuf = tbuf;
+ STRLEN len = 0; /* Hush gcc. len is always initialised before use. */
if (!sv) {
if (lp)
return SvPVX(sv);
}
if (SvIOKp(sv)) {
- if (SvIsUV(sv))
- (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
- else
- (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
+ len = SvIsUV(sv) ? my_sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv))
+ : my_sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
tsv = Nullsv;
- goto tokensave;
+ goto tokensave_has_len;
}
if (SvNOKp(sv)) {
Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
}
tsv = NEWSV(0,0);
if (SvOBJECT(sv)) {
- const char *name = HvNAME_get(SvSTASH(sv));
+ const char * const name = HvNAME_get(SvSTASH(sv));
Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
name ? name : "__ANON__" , typestr, PTR2UV(sv));
}
return (char *)"";
}
{
- STRLEN len = s - SvPVX_const(sv);
+ const STRLEN len = s - SvPVX_const(sv);
if (lp)
*lp = len;
SvCUR_set(sv, len);
return SvPVX(sv);
tokensave:
+ len = strlen(tmpbuf);
+ tokensave_has_len:
+ assert (!tsv);
if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
/* Sneaky stuff here */
tokensaveref:
if (!tsv)
- tsv = newSVpv(tmpbuf, 0);
+ tsv = newSVpvn(tmpbuf, len);
sv_2mortal(tsv);
if (lp)
*lp = SvCUR(tsv);
}
else {
dVAR;
- STRLEN len;
- const char *t;
- if (tsv) {
- sv_2mortal(tsv);
- t = SvPVX_const(tsv);
- len = SvCUR(tsv);
- }
- else {
- t = tmpbuf;
- len = strlen(tmpbuf);
- }
#ifdef FIXNEGATIVEZERO
- if (len == 2 && t[0] == '-' && t[1] == '0') {
- t = "0";
+ if (len == 2 && tmpbuf[0] == '-' && tmpbuf[1] == '0') {
+ tmpbuf[0] = '0';
+ tmpbuf[1] = 0;
len = 1;
}
#endif
s = SvGROW_mutable(sv, len + 1);
SvCUR_set(sv, len);
SvPOKp_on(sv);
- return memcpy(s, t, len + 1);
+ return memcpy(s, tmpbuf, len + 1);
}
}
}
/*
-=for apidoc sv_2pvbyte_nolen
-
-Return a pointer to the byte-encoded representation of the SV.
-May cause the SV to be downgraded from UTF-8 as a side-effect.
-
-Usually accessed via the C<SvPVbyte_nolen> macro.
-
-=cut
-*/
-
-char *
-Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
-{
- return sv_2pvbyte(sv, 0);
-}
-
-/*
=for apidoc sv_2pvbyte
Return a pointer to the byte-encoded representation of the SV, and set *lp
}
/*
-=for apidoc sv_2pvutf8_nolen
-
-Return a pointer to the UTF-8-encoded representation of the SV.
-May cause the SV to be upgraded to UTF-8 as a side-effect.
-
-Usually accessed via the C<SvPVutf8_nolen> macro.
-
-=cut
-*/
-
-char *
-Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
-{
- return sv_2pvutf8(sv, 0);
-}
-
-/*
=for apidoc sv_2pvutf8
Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
{
sv_utf8_upgrade(sv);
- return SvPV(sv,*lp);
+ return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
}
+
/*
=for apidoc sv_2bool
}
}
-/* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
- * this function provided for binary compatibility only
- */
-
-
-STRLEN
-Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
-{
- return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
-}
-
/*
=for apidoc sv_utf8_upgrade
* chars in the PV. Given that there isn't such a flag
* make the loop as fast as possible. */
const U8 *s = (U8 *) SvPVX_const(sv);
- const U8 *e = (U8 *) SvEND(sv);
+ const U8 * const e = (U8 *) SvEND(sv);
const U8 *t = s;
int hibit = 0;
return TRUE;
}
-/* sv_setsv() is now a macro using Perl_sv_setsv_flags();
- * this function provided for binary compatibility only
- */
-
-void
-Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
-{
- sv_setsv_flags(dstr, sstr, SV_GMAGIC);
-}
-
/*
=for apidoc sv_setsv
GvNAMELEN(dstr) = len;
SvFAKE_on(dstr); /* can coerce to non-glob */
}
- /* ahem, death to those who redefine active sort subs */
- else if (PL_curstackinfo->si_type == PERLSI_SORT
- && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
- Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
- GvNAME(dstr));
#ifdef GV_UNIQUE_CHECK
if (GvUNIQUE((GV*)dstr)) {
if (sflags & SVf_ROK) {
if (dtype >= SVt_PV) {
if (dtype == SVt_PVGV) {
- SV *sref = SvREFCNT_inc(SvRV(sstr));
+ SV * const sref = SvREFCNT_inc(SvRV(sstr));
SV *dref = 0;
const int intro = GvINTRO(dstr);
else
dref = (SV*)GvCV(dstr);
if (GvCV(dstr) != (CV*)sref) {
- CV* cv = GvCV(dstr);
+ CV* const cv = GvCV(dstr);
if (cv) {
if (!GvCVGEN((GV*)dstr) &&
(CvROOT(cv) || CvXSUB(cv)))
{
- /* ahem, death to those who redefine
- * active sort subs */
- if (PL_curstackinfo->si_type == PERLSI_SORT &&
- PL_sortcop == CvSTART(cv))
- Perl_croak(aTHX_
- "Can't redefine active sort subroutine %s",
- GvENAME((GV*)dstr));
/* Redefining a sub - warning is mandatory if
it was a const and its value changed. */
if (ckWARN(WARN_REDEFINE)
SvPV_set(sv, Nullch);
SvLEN_set(sv, 0);
SvGROW(sv, len + 1);
- Move(pvx,SvPVX_const(sv),len,char);
+ Move(pvx,SvPVX(sv),len,char);
*SvEND(sv) = '\0';
unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
}
}
/*
-=for apidoc sv_force_normal
-
-Undo various types of fakery on an SV: if the PV is a shared string, make
-a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
-an xpvmg. See also C<sv_force_normal_flags>.
-
-=cut
-*/
-
-void
-Perl_sv_force_normal(pTHX_ register SV *sv)
-{
- sv_force_normal_flags(sv, 0);
-}
-
-/*
=for apidoc sv_chop
Efficient removal of characters from the beginning of the string buffer.
const char *pvx = SvPVX_const(sv);
const STRLEN len = SvCUR(sv);
SvGROW(sv, len + 1);
- Move(pvx,SvPVX_const(sv),len,char);
+ Move(pvx,SvPVX(sv),len,char);
*SvEND(sv) = '\0';
}
SvIV_set(sv, 0);
SvIV_set(sv, SvIVX(sv) + delta);
}
-/* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
- * this function provided for binary compatibility only
- */
-
-void
-Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
-{
- sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
-}
-
/*
=for apidoc sv_catpvn
*SvEND(dsv) = '\0';
(void)SvPOK_only_UTF8(dsv); /* validate pointer */
SvTAINT(dsv);
-}
-
-/*
-=for apidoc sv_catpvn_mg
-
-Like C<sv_catpvn>, but also handles 'set' magic.
-
-=cut
-*/
-
-void
-Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
-{
- sv_catpvn(sv,ptr,len);
- SvSETMAGIC(sv);
-}
-
-/* sv_catsv() is now a macro using Perl_sv_catsv_flags();
- * this function provided for binary compatibility only
- */
-
-void
-Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
-{
- sv_catsv_flags(dstr, sstr, SV_GMAGIC);
+ if (flags & SV_SMAGIC)
+ SvSETMAGIC(dsv);
}
/*
{
const char *spv;
STRLEN slen;
- if (!ssv)
- return;
- if ((spv = SvPV_const(ssv, slen))) {
- /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
- gcc version 2.95.2 20000220 (Debian GNU/Linux) for
- Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
- get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
- dsv->sv_flags doesn't have that bit set.
+ if (ssv) {
+ if ((spv = SvPV_const(ssv, slen))) {
+ /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
+ gcc version 2.95.2 20000220 (Debian GNU/Linux) for
+ Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
+ get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
+ dsv->sv_flags doesn't have that bit set.
Andy Dougherty 12 Oct 2001
- */
- const I32 sutf8 = DO_UTF8(ssv);
- I32 dutf8;
+ */
+ const I32 sutf8 = DO_UTF8(ssv);
+ I32 dutf8;
- if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
- mg_get(dsv);
- dutf8 = DO_UTF8(dsv);
+ if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
+ mg_get(dsv);
+ dutf8 = DO_UTF8(dsv);
- if (dutf8 != sutf8) {
- if (dutf8) {
- /* Not modifying source SV, so taking a temporary copy. */
- SV* csv = sv_2mortal(newSVpvn(spv, slen));
+ if (dutf8 != sutf8) {
+ if (dutf8) {
+ /* Not modifying source SV, so taking a temporary copy. */
+ SV* csv = sv_2mortal(newSVpvn(spv, slen));
- sv_utf8_upgrade(csv);
- spv = SvPV_const(csv, slen);
+ sv_utf8_upgrade(csv);
+ spv = SvPV_const(csv, slen);
+ }
+ else
+ sv_utf8_upgrade_nomg(dsv);
}
- else
- sv_utf8_upgrade_nomg(dsv);
+ sv_catpvn_nomg(dsv, spv, slen);
}
- sv_catpvn_nomg(dsv, spv, slen);
}
-}
-
-/*
-=for apidoc sv_catsv_mg
-
-Like C<sv_catsv>, but also handles 'set' magic.
-
-=cut
-*/
-
-void
-Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
-{
- sv_catsv(dsv,ssv);
- SvSETMAGIC(dsv);
+ if (flags & SV_SMAGIC)
+ SvSETMAGIC(dsv);
}
/*
{
const U32 refcnt = SvREFCNT(sv);
SV_CHECK_THINKFIRST_COW_DROP(sv);
- if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
+ if (SvREFCNT(nsv) != 1) {
+ Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
+ UVuf " != 1)", (UV) SvREFCNT(nsv));
+ }
if (SvMAGICAL(sv)) {
if (SvMAGICAL(nsv))
mg_free(nsv);
/* PVIOs aren't from arenas */
goto freescalar;
case SVt_PVBM:
- old_body_arena = (void **) &PL_xpvbm_root;
+ old_body_arena = &PL_body_roots[SVt_PVBM];
goto freescalar;
case SVt_PVCV:
- old_body_arena = (void **) &PL_xpvcv_root;
+ old_body_arena = &PL_body_roots[SVt_PVCV];
case SVt_PVFM:
/* PVFMs aren't from arenas */
cv_undef((CV*)sv);
goto freescalar;
case SVt_PVHV:
hv_undef((HV*)sv);
- old_body_arena = (void **) &PL_xpvhv_root;
+ old_body_arena = &PL_body_roots[SVt_PVHV];
old_body_offset = STRUCT_OFFSET(XPVHV, xhv_fill);
break;
case SVt_PVAV:
av_undef((AV*)sv);
- old_body_arena = (void **) &PL_xpvav_root;
+ old_body_arena = &PL_body_roots[SVt_PVAV];
old_body_offset = STRUCT_OFFSET(XPVAV, xav_fill);
break;
case SVt_PVLV:
}
else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
SvREFCNT_dec(LvTARG(sv));
- old_body_arena = (void **) &PL_xpvlv_root;
+ old_body_arena = &PL_body_roots[SVt_PVLV];
goto freescalar;
case SVt_PVGV:
gp_free((GV*)sv);
have a back reference to us, which needs to be cleared. */
if (GvSTASH(sv))
sv_del_backref((SV*)GvSTASH(sv), sv);
- old_body_arena = (void **) &PL_xpvgv_root;
+ old_body_arena = &PL_body_roots[SVt_PVGV];
goto freescalar;
case SVt_PVMG:
- old_body_arena = (void **) &PL_xpvmg_root;
+ old_body_arena = &PL_body_roots[SVt_PVMG];
goto freescalar;
case SVt_PVNV:
- old_body_arena = (void **) &PL_xpvnv_root;
+ old_body_arena = &PL_body_roots[SVt_PVNV];
goto freescalar;
case SVt_PVIV:
- old_body_arena = (void **) &PL_xpviv_root;
+ old_body_arena = &PL_body_roots[SVt_PVIV];
old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur);
freescalar:
/* Don't bother with SvOOK_off(sv); as we're only going to free it. */
}
goto pvrv_common;
case SVt_PV:
- old_body_arena = (void **) &PL_xpv_root;
+ old_body_arena = &PL_body_roots[SVt_PV];
old_body_offset = STRUCT_OFFSET(XPV, xpv_cur);
case SVt_RV:
pvrv_common:
#endif
break;
case SVt_NV:
- old_body_arena = (void **) &PL_xnv_root;
+ old_body_arena = PL_body_roots[SVt_NV];
break;
}
screamer2:
if (rslen) {
- const register STDCHAR *bpe = buf + sizeof(buf);
+ register const STDCHAR *bpe = buf + sizeof(buf);
bp = buf;
while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
; /* keep reading */
av_clear(GvAV(gv));
}
if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
+#if defined(VMS)
+ Perl_die(aTHX_ "Can't reset %%ENV on this system");
+#else /* ! VMS */
hv_clear(GvHV(gv));
-#ifndef PERL_MICRO
-#ifdef USE_ENVIRON_ARRAY
- if (gv == PL_envgv
-# ifdef USE_ITHREADS
- && PL_curinterp == aTHX
-# endif
- )
- {
- environ[0] = Nullch;
- }
-#endif
-#endif /* !PERL_MICRO */
+# if defined(USE_ENVIRON_ARRAY)
+ if (gv == PL_envgv)
+ my_clearenv();
+# endif /* USE_ENVIRON_ARRAY */
+#endif /* VMS */
}
}
}
default:
SvGETMAGIC(sv);
if (SvROK(sv)) {
- SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
+ SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
tryAMAGICunDEREF(to_cv);
sv = SvRV(sv);
if (!sv)
return 0;
if (SvPOK(sv)) {
- const register XPV* tXpv;
- if ((tXpv = (XPV*)SvANY(sv)) &&
+ register const XPV* const tXpv = (XPV*)SvANY(sv);
+ if (tXpv &&
(tXpv->xpv_cur > 1 ||
(tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
return 1;
}
/*
-=for apidoc sv_iv
-
-A private implementation of the C<SvIVx> macro for compilers which can't
-cope with complex macro expressions. Always use the macro instead.
-
-=cut
-*/
-
-IV
-Perl_sv_iv(pTHX_ register SV *sv)
-{
- if (SvIOK(sv)) {
- if (SvIsUV(sv))
- return (IV)SvUVX(sv);
- return SvIVX(sv);
- }
- return sv_2iv(sv);
-}
-
-/*
-=for apidoc sv_uv
-
-A private implementation of the C<SvUVx> macro for compilers which can't
-cope with complex macro expressions. Always use the macro instead.
-
-=cut
-*/
-
-UV
-Perl_sv_uv(pTHX_ register SV *sv)
-{
- if (SvIOK(sv)) {
- if (SvIsUV(sv))
- return SvUVX(sv);
- return (UV)SvIVX(sv);
- }
- return sv_2uv(sv);
-}
-
-/*
-=for apidoc sv_nv
-
-A private implementation of the C<SvNVx> macro for compilers which can't
-cope with complex macro expressions. Always use the macro instead.
-
-=cut
-*/
-
-NV
-Perl_sv_nv(pTHX_ register SV *sv)
-{
- if (SvNOK(sv))
- return SvNVX(sv);
- return sv_2nv(sv);
-}
-
-/* sv_pv() is now a macro using SvPV_nolen();
- * this function provided for binary compatibility only
- */
-
-char *
-Perl_sv_pv(pTHX_ SV *sv)
-{
- if (SvPOK(sv))
- return SvPVX(sv);
-
- return sv_2pv(sv, 0);
-}
-
-/*
-=for apidoc sv_pv
-
-Use the C<SvPV_nolen> macro instead
-
-=for apidoc sv_pvn
-
-A private implementation of the C<SvPV> macro for compilers which can't
-cope with complex macro expressions. Always use the macro instead.
-
-=cut
-*/
-
-char *
-Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
-{
- if (SvPOK(sv)) {
- *lp = SvCUR(sv);
- return SvPVX(sv);
- }
- return sv_2pv(sv, lp);
-}
-
-
-char *
-Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
-{
- if (SvPOK(sv)) {
- *lp = SvCUR(sv);
- return SvPVX(sv);
- }
- return sv_2pv_flags(sv, lp, 0);
-}
-
-/* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
- * this function provided for binary compatibility only
- */
-
-char *
-Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
-{
- return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
-}
-
-/*
=for apidoc sv_pvn_force
Get a sensible string out of the SV somehow.
sv_unref(sv);
SvUPGRADE(sv, SVt_PV); /* Never FALSE */
SvGROW(sv, len + 1);
- Move(s,SvPVX_const(sv),len,char);
+ Move(s,SvPVX(sv),len,char);
SvCUR_set(sv, len);
*SvEND(sv) = '\0';
}
return SvPVX_mutable(sv);
}
-/* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
- * this function provided for binary compatibility only
- */
-
-char *
-Perl_sv_pvbyte(pTHX_ SV *sv)
-{
- sv_utf8_downgrade(sv,0);
- return sv_pv(sv);
-}
-
-/*
-=for apidoc sv_pvbyte
-
-Use C<SvPVbyte_nolen> instead.
-
-=for apidoc sv_pvbyten
-
-A private implementation of the C<SvPVbyte> macro for compilers
-which can't cope with complex macro expressions. Always use the macro
-instead.
-
-=cut
-*/
-
-char *
-Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
-{
- sv_utf8_downgrade(sv,0);
- return sv_pvn(sv,lp);
-}
-
/*
=for apidoc sv_pvbyten_force
-A private implementation of the C<SvPVbytex_force> macro for compilers
-which can't cope with complex macro expressions. Always use the macro
-instead.
+The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
=cut
*/
return SvPVX(sv);
}
-/* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
- * this function provided for binary compatibility only
- */
-
-char *
-Perl_sv_pvutf8(pTHX_ SV *sv)
-{
- sv_utf8_upgrade(sv);
- return sv_pv(sv);
-}
-
-/*
-=for apidoc sv_pvutf8
-
-Use the C<SvPVutf8_nolen> macro instead
-
-=for apidoc sv_pvutf8n
-
-A private implementation of the C<SvPVutf8> macro for compilers
-which can't cope with complex macro expressions. Always use the macro
-instead.
-
-=cut
-*/
-
-char *
-Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
-{
- sv_utf8_upgrade(sv);
- return sv_pvn(sv,lp);
-}
-
/*
=for apidoc sv_pvutf8n_force
-A private implementation of the C<SvPVutf8_force> macro for compilers
-which can't cope with complex macro expressions. Always use the macro
-instead.
+The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
=cut
*/
}
/*
-=for apidoc sv_unref
-
-Unsets the RV status of the SV, and decrements the reference count of
-whatever was being referenced by the RV. This can almost be thought of
-as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
-being zero. See C<SvROK_off>.
-
-=cut
-*/
-
-void
-Perl_sv_unref(pTHX_ SV *sv)
-{
- sv_unref_flags(sv, 0);
-}
-
-/*
-=for apidoc sv_taint
-
-Taint an SV. Use C<SvTAINTED_on> instead.
-=cut
-*/
-
-void
-Perl_sv_taint(pTHX_ SV *sv)
-{
- sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
-}
-
-/*
=for apidoc sv_untaint
Untaint an SV. Use C<SvTAINTED_off> instead.
Perl_sv_tainted(pTHX_ SV *sv)
{
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
- MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
+ const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
if (mg && (mg->mg_len & 1) )
return TRUE;
}
void
Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
{
- char buf[TYPE_CHARS(UV)];
- char *ebuf;
- char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
-
- sv_setpvn(sv, ptr, ebuf - ptr);
+ sv_setpviv(sv, iv);
SvSETMAGIC(sv);
}
{
q++; /* skip past the rest of the %vd format */
eptr = (const char *) vecstr;
- elen = strlen(eptr);
+ elen = veclen;
vectorize=FALSE;
goto string;
}
aka precis is 0 */
if ( c == 'g' && precis) {
Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
- if (*PL_efloatbuf) /* May return an empty string for digits==0 */
+ /* May return an empty string for digits==0 */
+ if (*PL_efloatbuf) {
+ elen = strlen(PL_efloatbuf);
goto float_converted;
+ }
} else if ( c == 'f' && !precis) {
if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
break;
* where printf() taints but print($float) doesn't.
* --jhi */
#if defined(HAS_LONG_DOUBLE)
- if (intsize == 'q')
- (void)sprintf(PL_efloatbuf, ptr, nv);
- else
- (void)sprintf(PL_efloatbuf, ptr, (double)nv);
+ elen = ((intsize == 'q')
+ ? my_sprintf(PL_efloatbuf, ptr, nv)
+ : my_sprintf(PL_efloatbuf, ptr, (double)nv));
#else
- (void)sprintf(PL_efloatbuf, ptr, nv);
+ elen = my_sprintf(PL_efloatbuf, ptr, nv);
#endif
}
float_converted:
eptr = PL_efloatbuf;
- elen = strlen(PL_efloatbuf);
break;
/* SPECIAL */
&& (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
&& ckWARN(WARN_PRINTF))
{
- SV *msg = sv_newmortal();
+ SV * const msg = sv_newmortal();
Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
(PL_op->op_type == OP_PRTF) ? "" : "s");
if (c) {
if (mg->mg_type == PERL_MAGIC_overload_table &&
AMT_AMAGIC((AMT*)mg->mg_ptr))
{
- AMT *amtp = (AMT*)mg->mg_ptr;
- AMT *namtp = (AMT*)nmg->mg_ptr;
+ AMT * const amtp = (AMT*)mg->mg_ptr;
+ AMT * const namtp = (AMT*)nmg->mg_ptr;
I32 i;
for (i = 1; i < NofAMmeth; i++) {
namtp->table[i] = cv_dup_inc(amtp->table[i], param);
# define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
#endif
-#define del_pte(p) del_body_type(p, struct ptr_tbl_ent, pte)
+/*
+ we use the PTE_SVSLOT 'reservation' made above, both here (in the
+ following define) and at call to new_body_inline made below in
+ Perl_ptr_table_store()
+ */
+
+#define del_pte(p) del_body_type(p, PTE_SVSLOT)
/* map an existing pointer using a table */
/* add a new entry to a pointer-mapping table */
void
-Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldv, void *newv)
+Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
{
PTR_TBL_ENT_t *tblent, **otblent;
/* 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 */
- const UV hash = PTR_TABLE_HASH(oldv);
+ const UV hash = PTR_TABLE_HASH(oldsv);
bool empty = 1;
assert(tbl);
otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
- if (tblent->oldval == oldv) {
- tblent->newval = newv;
+ if (tblent->oldval == oldsv) {
+ tblent->newval = newsv;
return;
}
}
- new_body_inline(tblent, (void**)&PL_pte_arenaroot, (void**)&PL_pte_root,
- sizeof(struct ptr_tbl_ent));
- tblent->oldval = oldv;
- tblent->newval = newv;
+ new_body_inline(tblent, (void**)&PL_pte_root,
+ sizeof(struct ptr_tbl_ent), PTE_SVSLOT);
+ tblent->oldval = oldsv;
+ tblent->newval = newsv;
tblent->next = *otblent;
*otblent = tblent;
tbl->tbl_items++;
if(SvTYPE(sstr) == SVt_PVHV &&
(hvname = HvNAME_get(sstr))) {
/** don't clone stashes if they already exist **/
- HV* old_stash = gv_stashpv(hvname,0);
- return (SV*) old_stash;
+ return (SV*)gv_stashpv(hvname,0);
}
}
void **new_body_arena;
void **new_body_arenaroot;
void *new_body;
+ svtype sv_type = SvTYPE(sstr);
- switch (SvTYPE(sstr)) {
+ switch (sv_type) {
default:
Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]",
(IV)SvTYPE(sstr));
break;
case SVt_PVHV:
- new_body_arena = (void **) &PL_xpvhv_root;
- new_body_arenaroot = (void **) &PL_xpvhv_arenaroot;
- new_body_offset = STRUCT_OFFSET(XPVHV, xhv_fill)
- - STRUCT_OFFSET(xpvhv_allocated, xhv_fill);
+ new_body_arena = &PL_body_roots[SVt_PVHV];
+ new_body_arenaroot = &PL_body_arenaroots[SVt_PVHV];
+ new_body_offset = - offset_by_svtype[SVt_PVHV];
+
new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash)
+ sizeof (((XPVHV*)SvANY(sstr))->xmg_stash)
- new_body_offset;
goto new_body;
case SVt_PVAV:
- new_body_arena = (void **) &PL_xpvav_root;
- new_body_arenaroot = (void **) &PL_xpvav_arenaroot;
- new_body_offset = STRUCT_OFFSET(XPVAV, xav_fill)
- - STRUCT_OFFSET(xpvav_allocated, xav_fill);
+ new_body_arena = &PL_body_roots[SVt_PVAV];
+ new_body_arenaroot = &PL_body_arenaroots[SVt_PVAV];
+ new_body_offset = - offset_by_svtype[SVt_PVAV];
+
new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash)
+ sizeof (((XPVHV*)SvANY(sstr))->xmg_stash)
- new_body_offset;
goto new_body;
- case SVt_PVBM:
- new_body_length = sizeof(XPVBM);
- new_body_arena = (void **) &PL_xpvbm_root;
- new_body_arenaroot = (void **) &PL_xpvbm_arenaroot;
- goto new_body;
case SVt_PVGV:
if (GvUNIQUE((GV*)sstr)) {
- /* Do sharing here. */
+ /* Do sharing here, and fall through */
}
- new_body_length = sizeof(XPVGV);
- new_body_arena = (void **) &PL_xpvgv_root;
- new_body_arenaroot = (void **) &PL_xpvgv_arenaroot;
- goto new_body;
+ case SVt_PVBM:
case SVt_PVCV:
- new_body_length = sizeof(XPVCV);
- new_body_arena = (void **) &PL_xpvcv_root;
- new_body_arenaroot = (void **) &PL_xpvcv_arenaroot;
- goto new_body;
case SVt_PVLV:
- new_body_length = sizeof(XPVLV);
- new_body_arena = (void **) &PL_xpvlv_root;
- new_body_arenaroot = (void **) &PL_xpvlv_arenaroot;
- goto new_body;
case SVt_PVMG:
- new_body_length = sizeof(XPVMG);
- new_body_arena = (void **) &PL_xpvmg_root;
- new_body_arenaroot = (void **) &PL_xpvmg_arenaroot;
- goto new_body;
case SVt_PVNV:
- new_body_length = sizeof(XPVNV);
- new_body_arena = (void **) &PL_xpvnv_root;
- new_body_arenaroot = (void **) &PL_xpvnv_arenaroot;
+ new_body_length = sizeof_body_by_svtype[sv_type];
+ new_body_arena = &PL_body_roots[sv_type];
+ new_body_arenaroot = &PL_body_arenaroots[sv_type];
goto new_body;
+
case SVt_PVIV:
- new_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur)
- - STRUCT_OFFSET(xpviv_allocated, xpv_cur);
+ new_body_offset = - offset_by_svtype[SVt_PVIV];
new_body_length = sizeof(XPVIV) - new_body_offset;
- new_body_arena = (void **) &PL_xpviv_root;
- new_body_arenaroot = (void **) &PL_xpviv_arenaroot;
+ new_body_arena = &PL_body_roots[SVt_PVIV];
+ new_body_arenaroot = &PL_body_arenaroots[SVt_PVIV];
goto new_body;
case SVt_PV:
- new_body_offset = STRUCT_OFFSET(XPV, xpv_cur)
- - STRUCT_OFFSET(xpv_allocated, xpv_cur);
+ new_body_offset = - offset_by_svtype[SVt_PV];
new_body_length = sizeof(XPV) - new_body_offset;
- new_body_arena = (void **) &PL_xpv_root;
- new_body_arenaroot = (void **) &PL_xpv_arenaroot;
+ new_body_arena = &PL_body_roots[SVt_PV];
+ new_body_arenaroot = &PL_body_arenaroots[SVt_PV];
new_body:
assert(new_body_length);
#ifndef PURIFY
- new_body_inline(new_body, new_body_arenaroot, new_body_arena,
- new_body_length);
+ new_body_inline(new_body, new_body_arena,
+ new_body_length, SvTYPE(sstr));
+
new_body = (void*)((char*)new_body - new_body_offset);
#else
/* We always allocated the full length item with PURIFY */
char);
HvARRAY(dstr) = (HE**)darray;
while (i <= sxhv->xhv_max) {
- HE *source = HvARRAY(sstr)[i];
+ const HE *source = HvARRAY(sstr)[i];
HvARRAY(dstr)[i] = source
? he_dup(source, sharekeys, param) : 0;
++i;
param->flags = flags;
param->proto_perl = proto_perl;
- /* arena roots */
- PL_xnv_arenaroot = NULL;
- PL_xnv_root = NULL;
- PL_xpv_arenaroot = NULL;
- PL_xpv_root = NULL;
- PL_xpviv_arenaroot = NULL;
- PL_xpviv_root = NULL;
- PL_xpvnv_arenaroot = NULL;
- PL_xpvnv_root = NULL;
- PL_xpvcv_arenaroot = NULL;
- PL_xpvcv_root = NULL;
- PL_xpvav_arenaroot = NULL;
- PL_xpvav_root = NULL;
- PL_xpvhv_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;
+ Zero(&PL_body_arenaroots, 1, PL_body_arenaroots);
+ Zero(&PL_body_roots, 1, PL_body_roots);
+
PL_he_arenaroot = NULL;
PL_he_root = NULL;
+
#if defined(USE_ITHREADS)
PL_pte_arenaroot = NULL;
PL_pte_root = NULL;
PL_statusvalue = proto_perl->Istatusvalue;
#ifdef VMS
PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
+#else
+ PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
#endif
PL_encoding = sv_dup(proto_perl->Iencoding, param);
PL_evalseq = proto_perl->Ievalseq;
PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
PL_origalen = proto_perl->Iorigalen;
+#ifdef PERL_USES_PL_PIDSTATUS
PL_pidstatus = newHV(); /* XXX flag for cloning? */
+#endif
PL_osname = SAVEPV(proto_perl->Iosname);
PL_sighandlerp = proto_perl->Isighandlerp;
PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
- PL_sortcxix = proto_perl->Tsortcxix;
PL_efloatbuf = Nullch; /* reinits on demand */
PL_efloatsize = 0; /* reinits on demand */