diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | embed.fnc | 6 | ||||
| -rw-r--r-- | embed.h | 4 | ||||
| -rw-r--r-- | perl.h | 7 | ||||
| -rw-r--r-- | proto.h | 6 | ||||
| -rw-r--r-- | sv.c | 373 | ||||
| -rw-r--r-- | sv.h | 3 | ||||
| -rw-r--r-- | sv_inline.h | 495 |
8 files changed, 525 insertions, 370 deletions
@@ -5569,6 +5569,7 @@ scope.h Scope entry and exit header SECURITY.md Add Security Policy for GitHub sv.c Scalar value code sv.h Scalar value header +sv_inline.h Perl_newSV_type and required defs t/base/cond.t See if conditionals work t/base/if.t See if if works t/base/lex.t See if lexical items work @@ -1519,7 +1519,7 @@ Apd |SV* |newSVrv |NN SV *const rv|NULLOK const char *const classname ApMbdR |SV* |newSVsv |NULLOK SV *const old AmdR |SV* |newSVsv_nomg |NULLOK SV *const old AdpR |SV* |newSVsv_flags |NULLOK SV *const old|I32 flags -ApdR |SV* |newSV_type |const svtype type +ApdiR |SV* |newSV_type |const svtype type ApdR |OP* |newUNOP |I32 type|I32 flags|NULLOK OP* first ApdR |OP* |newUNOP_AUX |I32 type|I32 flags|NULLOK OP* first \ |NULLOK UNOP_AUX_item *aux @@ -3171,7 +3171,7 @@ S |STRLEN |sv_pos_b2u_midway|NN const U8 *const s|NN const U8 *const target \ S |void |assert_uft8_cache_coherent|NN const char *const func \ |STRLEN from_cache|STRLEN real|NN SV *const sv ST |char * |F0convert |NV nv|NN char *const endbuf|NN STRLEN *const len -S |SV * |more_sv +Cp |SV * |more_sv S |bool |sv_2iuv_common |NN SV *const sv S |void |glob_assign_glob|NN SV *const dsv|NN SV *const ssv \ |const int dtype @@ -3180,7 +3180,7 @@ S |void |anonymise_cv_maybe |NN GV *gv|NN CV *cv #endif : Used in sv.c and hv.c -po |void * |more_bodies |const svtype sv_type|const size_t body_size \ +Cpo |void * |more_bodies |const svtype sv_type|const size_t body_size \ |const size_t arena_size EXpR |SV* |get_and_check_backslash_N_name|NN const char* s \ |NN const char* e \ @@ -881,6 +881,9 @@ #define dump_mstats(a) Perl_dump_mstats(aTHX_ a) #define get_mstats(a,b,c) Perl_get_mstats(aTHX_ a,b,c) #endif +#if defined(PERL_IN_SV_C) +#define more_sv() Perl_more_sv(aTHX) +#endif #if defined(PERL_USE_3ARG_SIGHANDLER) #define csighandler Perl_csighandler #endif @@ -1932,7 +1935,6 @@ #define find_uninit_var(a,b,c,d) S_find_uninit_var(aTHX_ a,b,c,d) #define glob_2number(a) S_glob_2number(aTHX_ a) #define glob_assign_glob(a,b,c) S_glob_assign_glob(aTHX_ a,b,c) -#define more_sv() S_more_sv(aTHX) #define not_a_number(a) S_not_a_number(aTHX_ a) #define not_incrementable(a) S_not_incrementable(aTHX_ a) #define ptr_table_find S_ptr_table_find @@ -1252,12 +1252,6 @@ Use L</UV> to declare variables of the maximum usable size on this platform. (((U64)(x) & UINT64_C(0xff00000000000000)) >> 56) )) # endif -/* The old value was hard coded at 1008. (4096-16) seems to be a bit faster, - at least on FreeBSD. YMMV, so experiment. */ -#ifndef PERL_ARENA_SIZE -#define PERL_ARENA_SIZE 4080 -#endif - /* Maximum level of recursion */ #ifndef PERL_SUB_DEPTH_WARN #define PERL_SUB_DEPTH_WARN 100 @@ -7160,6 +7154,7 @@ cannot have changed since the precalculation. START_EXTERN_C # include "inline.h" +# include "sv_inline.h" END_EXTERN_C @@ -2482,9 +2482,11 @@ PERL_CALLCONV OP* Perl_newSVREF(pTHX_ OP* o) #define PERL_ARGS_ASSERT_NEWSVREF \ assert(o) -PERL_CALLCONV SV* Perl_newSV_type(pTHX_ const svtype type) +#ifndef PERL_NO_INLINE_FUNCTIONS +PERL_STATIC_INLINE SV* Perl_newSV_type(pTHX_ const svtype type) __attribute__warn_unused_result__; #define PERL_ARGS_ASSERT_NEWSV_TYPE +#endif PERL_CALLCONV SV* Perl_newSVavdefelem(pTHX_ AV *av, SSize_t ix, bool extendible) __attribute__warn_unused_result__; @@ -6461,7 +6463,7 @@ STATIC bool S_glob_2number(pTHX_ GV* const gv); STATIC void S_glob_assign_glob(pTHX_ SV *const dsv, SV *const ssv, const int dtype); #define PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB \ assert(dsv); assert(ssv) -STATIC SV * S_more_sv(pTHX); +PERL_CALLCONV SV * Perl_more_sv(pTHX); #define PERL_ARGS_ASSERT_MORE_SV STATIC void S_not_a_number(pTHX_ SV *const sv); #define PERL_ARGS_ASSERT_NOT_A_NUMBER \ @@ -230,16 +230,6 @@ Public API: * "A time to plant, and a time to uproot what was planted..." */ -#ifdef PERL_MEM_LOG -# define MEM_LOG_NEW_SV(sv, file, line, func) \ - Perl_mem_log_new_sv(sv, file, line, func) -# define MEM_LOG_DEL_SV(sv, file, line, func) \ - Perl_mem_log_del_sv(sv, file, line, func) -#else -# define MEM_LOG_NEW_SV(sv, file, line, func) NOOP -# define MEM_LOG_DEL_SV(sv, file, line, func) NOOP -#endif - #ifdef DEBUG_LEAKING_SCALARS # define FREE_SV_DEBUG_FILE(sv) STMT_START { \ if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \ @@ -252,21 +242,6 @@ Public API: # define DEBUG_SV_SERIAL(sv) NOOP #endif -#ifdef PERL_POISON -# define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv) -# define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val)) -/* Whilst I'd love to do this, it seems that things like to check on - unreferenced scalars -# define POISON_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV) -*/ -# define POISON_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \ - PoisonNew(&SvREFCNT(sv), 1, U32) -#else -# define SvARENA_CHAIN(sv) SvANY(sv) -# define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val) -# define POISON_SV_HEAD(sv) -#endif - /* Mark an SV head as unused, and add to free list. * * If SVf_BREAK is set, skip adding it to the free list, as this SV had @@ -289,18 +264,11 @@ Public API: --PL_sv_count; \ } STMT_END -#define uproot_SV(p) \ - STMT_START { \ - (p) = PL_sv_root; \ - PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \ - ++PL_sv_count; \ - } STMT_END - /* make some more SVs by adding another arena */ -STATIC SV* -S_more_sv(pTHX) +SV* +Perl_more_sv(pTHX) { SV* sv; char *chunk; /* must use New here to match call to */ @@ -310,58 +278,6 @@ S_more_sv(pTHX) return sv; } -/* new_SV(): return a new, empty SV head */ - -#ifdef DEBUG_LEAKING_SCALARS -/* provide a real function for a debugger to play with */ -STATIC SV* -S_new_SV(pTHX_ const char *file, int line, const char *func) -{ - SV* sv; - - if (PL_sv_root) - uproot_SV(sv); - else - sv = S_more_sv(aTHX); - SvANY(sv) = 0; - SvREFCNT(sv) = 1; - SvFLAGS(sv) = 0; - sv->sv_debug_optype = PL_op ? PL_op->op_type : 0; - sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE - ? PL_parser->copline - : PL_curcop - ? CopLINE(PL_curcop) - : 0 - ); - sv->sv_debug_inpad = 0; - sv->sv_debug_parent = NULL; - sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL; - - sv->sv_debug_serial = PL_sv_serial++; - - MEM_LOG_NEW_SV(sv, file, line, func); - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) new_SV (from %s:%d [%s])\n", - PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func)); - - return sv; -} -# define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__) - -#else -# define new_SV(p) \ - STMT_START { \ - if (PL_sv_root) \ - uproot_SV(p); \ - else \ - (p) = S_more_sv(aTHX); \ - SvANY(p) = 0; \ - SvREFCNT(p) = 1; \ - SvFLAGS(p) = 0; \ - MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \ - } STMT_END -#endif - - /* del_SV(): return an empty SV head to the free list */ #ifdef DEBUGGING @@ -768,8 +684,12 @@ Perl_sv_free_arenas(pTHX) } /* - Here are mid-level routines that manage the allocation of bodies out - of the various arenas. There are 4 kinds of arenas: + Historically, here were mid-level routines that manage the + allocation of bodies out of the various arenas. Some of these + routines and related definitions remain here, but otherse were + moved into sv_inline.h to facilitate inlining of newSV_type(). + + There are 4 kinds of arenas: 1. SV-head arenas, which are discussed and handled above 2. regular body arenas @@ -871,173 +791,6 @@ available in hv.c. Similarly SVt_IV is re-used for HVAUX_ARENA_ROOT_IX. */ -typedef struct xpvhv_with_aux XPVHV_WITH_AUX; - -struct body_details { - U8 body_size; /* Size to allocate */ - U8 copy; /* Size of structure to copy (may be shorter) */ - U8 offset; /* Size of unalloced ghost fields to first alloced field*/ - PERL_BITFIELD8 type : 4; /* We have space for a sanity check. */ - PERL_BITFIELD8 cant_upgrade : 1;/* Cannot upgrade this type */ - PERL_BITFIELD8 zero_nv : 1; /* zero the NV when upgrading from this */ - PERL_BITFIELD8 arena : 1; /* Allocated from an arena */ - U32 arena_size; /* Size of arena to allocate */ -}; - -#define ALIGNED_TYPE_NAME(name) name##_aligned -#define ALIGNED_TYPE(name) \ - typedef union { \ - name align_me; \ - NV nv; \ - IV iv; \ - } ALIGNED_TYPE_NAME(name) - -ALIGNED_TYPE(regexp); -ALIGNED_TYPE(XPVGV); -ALIGNED_TYPE(XPVLV); -ALIGNED_TYPE(XPVAV); -ALIGNED_TYPE(XPVHV); -ALIGNED_TYPE(XPVHV_WITH_AUX); -ALIGNED_TYPE(XPVCV); -ALIGNED_TYPE(XPVFM); -ALIGNED_TYPE(XPVIO); - -#define HADNV FALSE -#define NONV TRUE - - -#ifdef PURIFY -/* With -DPURFIY we allocate everything directly, and don't use arenas. - This seems a rather elegant way to simplify some of the code below. */ -#define HASARENA FALSE -#else -#define HASARENA TRUE -#endif -#define NOARENA FALSE - -/* Size the arenas to exactly fit a given number of bodies. A count - of 0 fits the max number bodies into a PERL_ARENA_SIZE.block, - simplifying the default. If count > 0, the arena is sized to fit - only that many bodies, allowing arenas to be used for large, rare - bodies (XPVFM, XPVIO) without undue waste. The arena size is - limited by PERL_ARENA_SIZE, so we can safely oversize the - declarations. - */ -#define FIT_ARENA0(body_size) \ - ((size_t)(PERL_ARENA_SIZE / body_size) * body_size) -#define FIT_ARENAn(count,body_size) \ - ( count * body_size <= PERL_ARENA_SIZE) \ - ? count * body_size \ - : FIT_ARENA0 (body_size) -#define FIT_ARENA(count,body_size) \ - (U32)(count \ - ? FIT_ARENAn (count, body_size) \ - : FIT_ARENA0 (body_size)) - -/* Calculate the length to copy. Specifically work out the length less any - final padding the compiler needed to add. See the comment in sv_upgrade - for why copying the padding proved to be a bug. */ - -#define copy_length(type, last_member) \ - STRUCT_OFFSET(type, last_member) \ - + sizeof (((type*)SvANY((const SV *)0))->last_member) - -static const struct body_details bodies_by_type[] = { - /* HEs use this offset for their arena. */ - { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 }, - - /* IVs are in the head, so the allocation size is 0. */ - { 0, - sizeof(IV), /* This is used to copy out the IV body. */ - STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV, - NOARENA /* IVS don't need an arena */, 0 - }, - -#if NVSIZE <= IVSIZE - { 0, sizeof(NV), - STRUCT_OFFSET(XPVNV, xnv_u), - SVt_NV, FALSE, HADNV, NOARENA, 0 }, -#else - { sizeof(NV), sizeof(NV), - STRUCT_OFFSET(XPVNV, xnv_u), - SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) }, -#endif - - { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur), - copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur), - + STRUCT_OFFSET(XPV, xpv_cur), - SVt_PV, FALSE, NONV, HASARENA, - FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) }, - - { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur), - copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur), - + STRUCT_OFFSET(XPV, xpv_cur), - SVt_INVLIST, TRUE, NONV, HASARENA, - FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) }, - - { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur), - copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur), - + STRUCT_OFFSET(XPV, xpv_cur), - SVt_PVIV, FALSE, NONV, HASARENA, - FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) }, - - { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur), - copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur), - + STRUCT_OFFSET(XPV, xpv_cur), - SVt_PVNV, FALSE, HADNV, HASARENA, - FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) }, - - { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV, - HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, - - { sizeof(ALIGNED_TYPE_NAME(regexp)), - sizeof(regexp), - 0, - SVt_REGEXP, TRUE, NONV, HASARENA, - FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(regexp))) - }, - - { sizeof(ALIGNED_TYPE_NAME(XPVGV)), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, - HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVGV))) }, - - { sizeof(ALIGNED_TYPE_NAME(XPVLV)), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV, - HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVLV))) }, - - { sizeof(ALIGNED_TYPE_NAME(XPVAV)), - copy_length(XPVAV, xav_alloc), - 0, - SVt_PVAV, TRUE, NONV, HASARENA, - FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVAV))) }, - - { sizeof(ALIGNED_TYPE_NAME(XPVHV)), - copy_length(XPVHV, xhv_max), - 0, - SVt_PVHV, TRUE, NONV, HASARENA, - FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV))) }, - - { sizeof(ALIGNED_TYPE_NAME(XPVCV)), - sizeof(XPVCV), - 0, - SVt_PVCV, TRUE, NONV, HASARENA, - FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVCV))) }, - - { sizeof(ALIGNED_TYPE_NAME(XPVFM)), - sizeof(XPVFM), - 0, - SVt_PVFM, TRUE, NONV, NOARENA, - FIT_ARENA(20, sizeof(ALIGNED_TYPE_NAME(XPVFM))) }, - - { sizeof(ALIGNED_TYPE_NAME(XPVIO)), - sizeof(XPVIO), - 0, - SVt_PVIO, TRUE, NONV, HASARENA, - FIT_ARENA(24, sizeof(ALIGNED_TYPE_NAME(XPVIO))) }, -}; - -#define new_body_allocated(sv_type) \ - (void *)((char *)S_new_body(aTHX_ sv_type) \ - - bodies_by_type[sv_type].offset) - /* return a thing to the free list */ #define del_body(thing, root) \ @@ -1047,35 +800,6 @@ static const struct body_details bodies_by_type[] = { *root = (void*)thing_copy; \ } STMT_END -#ifdef PURIFY -#if !(NVSIZE <= IVSIZE) -# define new_XNV() safemalloc(sizeof(XPVNV)) -#endif -#define new_XPVNV() safemalloc(sizeof(XPVNV)) -#define new_XPVMG() safemalloc(sizeof(XPVMG)) - -#define del_body_by_type(p, type) safefree(p) - -#else /* !PURIFY */ - -#if !(NVSIZE <= IVSIZE) -# define new_XNV() new_body_allocated(SVt_NV) -#endif -#define new_XPVNV() new_body_allocated(SVt_PVNV) -#define new_XPVMG() new_body_allocated(SVt_PVMG) - -#define del_body_by_type(p, type) \ - del_body(p + bodies_by_type[(type)].offset, \ - &PL_body_roots[(type)]) - -#endif /* PURIFY */ - -/* no arena for you! */ - -#define new_NOARENA(details) \ - safemalloc((details)->body_size + (details)->offset) -#define new_NOARENAZ(details) \ - safecalloc((details)->body_size + (details)->offset, 1) void * Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, @@ -1165,40 +889,6 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, } } -#ifndef PURIFY - -/* grab a new thing from the arena's free list, allocating more if necessary. */ -#define new_body_from_arena(xpv, root_index, type_meta) \ - STMT_START { \ - void ** const r3wt = &PL_body_roots[root_index]; \ - xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \ - ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ root_index, \ - type_meta.body_size,\ - type_meta.arena_size)); \ - *(r3wt) = *(void**)(xpv); \ - } STMT_END - -PERL_STATIC_INLINE void * -S_new_body(pTHX_ const svtype sv_type) -{ - void *xpv; - new_body_from_arena(xpv, sv_type, bodies_by_type[sv_type]); - return xpv; -} - -#endif - -static const struct body_details fake_rv = - { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 }; - -static const struct body_details fake_hv_with_aux = - /* The SVt_IV arena is used for (larger) PVHV bodies. */ - { sizeof(ALIGNED_TYPE_NAME(XPVHV_WITH_AUX)), - copy_length(XPVHV, xhv_max), - 0, - SVt_PVHV, TRUE, NONV, HASARENA, - FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV_WITH_AUX))) }; - /* =for apidoc sv_upgrade @@ -5860,9 +5550,10 @@ Perl_newSV(pTHX_ const STRLEN len) { SV *sv; - new_SV(sv); - if (len) { - sv_upgrade(sv, SVt_PV); + if (!len) + new_SV(sv); + else { + sv = newSV_type(SVt_PV); sv_grow_fresh(sv, len + 1); } return sv; @@ -9676,8 +9367,7 @@ Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags /* All the flags we don't support must be zero. And we're new code so I'm going to assert this from the start. */ assert(!(flags & ~(SVf_UTF8|SVs_TEMP))); - new_SV(sv); - sv_upgrade(sv, SVt_PV); + sv = newSV_type(SVt_PV); sv_setpvn_fresh(sv,s,len); /* This code used to do a sv_2mortal(), however we now unroll the call to @@ -9745,10 +9435,7 @@ to call C<strlen> use C<newSVpvn> instead (calling C<strlen> yourself). SV * Perl_newSVpv(pTHX_ const char *const s, const STRLEN len) { - SV *sv; - - new_SV(sv); - sv_upgrade(sv, SVt_PV); + SV *sv = newSV_type(SVt_PV); sv_setpvn_fresh(sv, s, len || s == NULL ? len : strlen(s)); return sv; } @@ -9769,9 +9456,7 @@ undefined. SV * Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len) { - SV *sv; - new_SV(sv); - sv_upgrade(sv, SVt_PV); + SV *sv = newSV_type(SVt_PV); sv_setpvn_fresh(sv,buffer,len); return sv; } @@ -9825,10 +9510,8 @@ Perl_newSVhek(pTHX_ const HEK *const hek) { /* Inline most of newSVpvn_share(), because share_hek_hek() is far more efficient than sharepvn(). */ - SV *sv; + SV *sv = newSV_type(SVt_PV); - new_SV(sv); - sv_upgrade(sv, SVt_PV); SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek))); SvCUR_set(sv, HEK_LEN(hek)); SvLEN_set(sv, 0); @@ -9873,10 +9556,9 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) } if (!hash) PERL_HASH(hash, src, len); - new_SV(sv); + sv = newSV_type(SVt_PV); /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it changes here, update it there too. */ - sv_upgrade(sv, SVt_PV); SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash)); SvCUR_set(sv, len); SvLEN_set(sv, 0); @@ -10066,27 +9748,6 @@ Perl_newSVuv(pTHX_ const UV u) } /* -=for apidoc newSV_type - -Creates a new SV, of the type specified. The reference count for the new SV -is set to 1. - -=cut -*/ - -SV * -Perl_newSV_type(pTHX_ const svtype type) -{ - SV *sv; - - new_SV(sv); - ASSUME(SvTYPE(sv) == SVt_FIRST); - if(type != SVt_FIRST) - sv_upgrade(sv, type); - return sv; -} - -/* =for apidoc newRV_noinc Creates an RV wrapper for an SV. The reference count for the original @@ -176,6 +176,7 @@ typedef enum { /* The array of arena roots for SV bodies is indexed by SvTYPE. SVt_NULL doesn't * use a body, so that arena root is re-used for HEs. SVt_IV also doesn't, so * that arena root is used for HVs with struct xpvhv_aux. */ + #if defined(PERL_IN_HV_C) || defined(PERL_IN_XS_APITEST) # define HE_ARENA_ROOT_IX SVt_NULL #endif @@ -2592,7 +2593,6 @@ Evaluates C<sv> more than once. Sets C<len> to 0 if C<SvOOK(sv)> is false. /* The following two macros compute the necessary offsets for the above * trick and store them in SvANY for SvIV() (and friends) to use. */ -#ifdef PERL_CORE # define SET_SVANY_FOR_BODYLESS_IV(sv) \ SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) \ - STRUCT_OFFSET(XPVIV, xiv_iv)) @@ -2600,7 +2600,6 @@ Evaluates C<sv> more than once. Sets C<len> to 0 if C<SvOOK(sv)> is false. # define SET_SVANY_FOR_BODYLESS_NV(sv) \ SvANY(sv) = (XPVNV*)((char*)&(sv->sv_u.svu_nv) \ - STRUCT_OFFSET(XPVNV, xnv_u.xnv_nv)) -#endif /* * ex: set ts=8 sts=4 sw=4 et: diff --git a/sv_inline.h b/sv_inline.h new file mode 100644 index 0000000000..70ebb4ae3b --- /dev/null +++ b/sv_inline.h @@ -0,0 +1,495 @@ +/* sv.h + * + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ + + +/* 2022 */ +/* BLAH BLAH BLAH */ + +/* This came from perl.h*/ + +/* The old value was hard coded at 1008. (4096-16) seems to be a bit faster, + at least on FreeBSD. YMMV, so experiment. */ +#ifndef PERL_ARENA_SIZE +#define PERL_ARENA_SIZE 4080 +#endif + +/* All other pre-existing definitions and functions that were moved into this + * file originally came from sv.c. */ + +#ifdef PERL_POISON +# define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv) +# define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val)) +/* Whilst I'd love to do this, it seems that things like to check on + unreferenced scalars +# define POISON_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV) +*/ +# define POISON_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \ + PoisonNew(&SvREFCNT(sv), 1, U32) +#else +# define SvARENA_CHAIN(sv) SvANY(sv) +# define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val) +# define POISON_SV_HEAD(sv) +#endif + +#ifdef PERL_MEM_LOG +# define MEM_LOG_NEW_SV(sv, file, line, func) \ + Perl_mem_log_new_sv(sv, file, line, func) +# define MEM_LOG_DEL_SV(sv, file, line, func) \ + Perl_mem_log_del_sv(sv, file, line, func) +#else +# define MEM_LOG_NEW_SV(sv, file, line, func) NOOP +# define MEM_LOG_DEL_SV(sv, file, line, func) NOOP +#endif + +#define uproot_SV(p) \ + STMT_START { \ + (p) = PL_sv_root; \ + PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \ + ++PL_sv_count; \ + } STMT_END + +/* Perl_more_sv lives in sv.c, we don't want to inline it. + * but the function declaration seems to be needed? */ +SV* Perl_more_sv(pTHX); + +/* new_SV(): return a new, empty SV head */ + +#ifdef DEBUG_LEAKING_SCALARS +/* provide a real function for a debugger to play with */ +STATIC SV* +S_new_SV(pTHX_ const char *file, int line, const char *func) +{ + SV* sv; + + if (PL_sv_root) + uproot_SV(sv); + else + sv = Perl_more_sv(aTHX); + SvANY(sv) = 0; + SvREFCNT(sv) = 1; + SvFLAGS(sv) = 0; + sv->sv_debug_optype = PL_op ? PL_op->op_type : 0; + sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE + ? PL_parser->copline + : PL_curcop + ? CopLINE(PL_curcop) + : 0 + ); + sv->sv_debug_inpad = 0; + sv->sv_debug_parent = NULL; + sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL; + + sv->sv_debug_serial = PL_sv_serial++; + + MEM_LOG_NEW_SV(sv, file, line, func); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) new_SV (from %s:%d [%s])\n", + PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func)); + + return sv; +} +# define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__) + +#else +# define new_SV(p) \ + STMT_START { \ + if (PL_sv_root) \ + uproot_SV(p); \ + else \ + (p) = Perl_more_sv(aTHX); \ + SvANY(p) = 0; \ + SvREFCNT(p) = 1; \ + SvFLAGS(p) = 0; \ + MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \ + } STMT_END +#endif + + +typedef struct xpvhv_with_aux XPVHV_WITH_AUX; + +struct body_details { + U8 body_size; /* Size to allocate */ + U8 copy; /* Size of structure to copy (may be shorter) */ + U8 offset; /* Size of unalloced ghost fields to first alloced field*/ + PERL_BITFIELD8 type : 4; /* We have space for a sanity check. */ + PERL_BITFIELD8 cant_upgrade : 1;/* Cannot upgrade this type */ + PERL_BITFIELD8 zero_nv : 1; /* zero the NV when upgrading from this */ + PERL_BITFIELD8 arena : 1; /* Allocated from an arena */ + U32 arena_size; /* Size of arena to allocate */ +}; + +#define ALIGNED_TYPE_NAME(name) name##_aligned +#define ALIGNED_TYPE(name) \ + typedef union { \ + name align_me; \ + NV nv; \ + IV iv; \ + } ALIGNED_TYPE_NAME(name) + +ALIGNED_TYPE(regexp); +ALIGNED_TYPE(XPVGV); +ALIGNED_TYPE(XPVLV); +ALIGNED_TYPE(XPVAV); +ALIGNED_TYPE(XPVHV); +ALIGNED_TYPE(XPVHV_WITH_AUX); +ALIGNED_TYPE(XPVCV); +ALIGNED_TYPE(XPVFM); +ALIGNED_TYPE(XPVIO); + +#define HADNV FALSE +#define NONV TRUE + + +#ifdef PURIFY +/* With -DPURFIY we allocate everything directly, and don't use arenas. + This seems a rather elegant way to simplify some of the code below. */ +#define HASARENA FALSE +#else +#define HASARENA TRUE +#endif +#define NOARENA FALSE + +/* Size the arenas to exactly fit a given number of bodies. A count + of 0 fits the max number bodies into a PERL_ARENA_SIZE.block, + simplifying the default. If count > 0, the arena is sized to fit + only that many bodies, allowing arenas to be used for large, rare + bodies (XPVFM, XPVIO) without undue waste. The arena size is + limited by PERL_ARENA_SIZE, so we can safely oversize the + declarations. + */ +#define FIT_ARENA0(body_size) \ + ((size_t)(PERL_ARENA_SIZE / body_size) * body_size) +#define FIT_ARENAn(count,body_size) \ + ( count * body_size <= PERL_ARENA_SIZE) \ + ? count * body_size \ + : FIT_ARENA0 (body_size) +#define FIT_ARENA(count,body_size) \ + (U32)(count \ + ? FIT_ARENAn (count, body_size) \ + : FIT_ARENA0 (body_size)) + +/* Calculate the length to copy. Specifically work out the length less any + final padding the compiler needed to add. See the comment in sv_upgrade + for why copying the padding proved to be a bug. */ + +#define copy_length(type, last_member) \ + STRUCT_OFFSET(type, last_member) \ + + sizeof (((type*)SvANY((const SV *)0))->last_member) + +static const struct body_details bodies_by_type[] = { + /* HEs use this offset for their arena. */ + { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 }, + + /* IVs are in the head, so the allocation size is 0. */ + { 0, + sizeof(IV), /* This is used to copy out the IV body. */ + STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV, + NOARENA /* IVS don't need an arena */, 0 + }, + +#if NVSIZE <= IVSIZE + { 0, sizeof(NV), + STRUCT_OFFSET(XPVNV, xnv_u), + SVt_NV, FALSE, HADNV, NOARENA, 0 }, +#else + { sizeof(NV), sizeof(NV), + STRUCT_OFFSET(XPVNV, xnv_u), + SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) }, +#endif + + { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur), + copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur), + + STRUCT_OFFSET(XPV, xpv_cur), + SVt_PV, FALSE, NONV, HASARENA, + FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) }, + + { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur), + copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur), + + STRUCT_OFFSET(XPV, xpv_cur), + SVt_INVLIST, TRUE, NONV, HASARENA, + FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) }, + + { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur), + copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur), + + STRUCT_OFFSET(XPV, xpv_cur), + SVt_PVIV, FALSE, NONV, HASARENA, + FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) }, + + { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur), + copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur), + + STRUCT_OFFSET(XPV, xpv_cur), + SVt_PVNV, FALSE, HADNV, HASARENA, + FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) }, + + { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV, + HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, + + { sizeof(ALIGNED_TYPE_NAME(regexp)), + sizeof(regexp), + 0, + SVt_REGEXP, TRUE, NONV, HASARENA, + FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(regexp))) + }, + + { sizeof(ALIGNED_TYPE_NAME(XPVGV)), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, + HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVGV))) }, + + { sizeof(ALIGNED_TYPE_NAME(XPVLV)), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV, + HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVLV))) }, + + { sizeof(ALIGNED_TYPE_NAME(XPVAV)), + copy_length(XPVAV, xav_alloc), + 0, + SVt_PVAV, TRUE, NONV, HASARENA, + FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVAV))) }, + + { sizeof(ALIGNED_TYPE_NAME(XPVHV)), + copy_length(XPVHV, xhv_max), + 0, + SVt_PVHV, TRUE, NONV, HASARENA, + FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV))) }, + + { sizeof(ALIGNED_TYPE_NAME(XPVCV)), + sizeof(XPVCV), + 0, + SVt_PVCV, TRUE, NONV, HASARENA, + FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVCV))) }, + + { sizeof(ALIGNED_TYPE_NAME(XPVFM)), + sizeof(XPVFM), + 0, + SVt_PVFM, TRUE, NONV, NOARENA, + FIT_ARENA(20, sizeof(ALIGNED_TYPE_NAME(XPVFM))) }, + + { sizeof(ALIGNED_TYPE_NAME(XPVIO)), + sizeof(XPVIO), + 0, + SVt_PVIO, TRUE, NONV, HASARENA, + FIT_ARENA(24, sizeof(ALIGNED_TYPE_NAME(XPVIO))) }, +}; + +#define new_body_allocated(sv_type) \ + (void *)((char *)S_new_body(aTHX_ sv_type) \ + - bodies_by_type[sv_type].offset) + +#ifdef PURIFY +#if !(NVSIZE <= IVSIZE) +# define new_XNV() safemalloc(sizeof(XPVNV)) +#endif +#define new_XPVNV() safemalloc(sizeof(XPVNV)) +#define new_XPVMG() safemalloc(sizeof(XPVMG)) + +#define del_body_by_type(p, type) safefree(p) + +#else /* !PURIFY */ + +#if !(NVSIZE <= IVSIZE) +# define new_XNV() new_body_allocated(SVt_NV) +#endif +#define new_XPVNV() new_body_allocated(SVt_PVNV) +#define new_XPVMG() new_body_allocated(SVt_PVMG) + +#define del_body_by_type(p, type) \ + del_body(p + bodies_by_type[(type)].offset, \ + &PL_body_roots[(type)]) + +#endif /* PURIFY */ + +/* no arena for you! */ + +#define new_NOARENA(details) \ + safemalloc((details)->body_size + (details)->offset) +#define new_NOARENAZ(details) \ + safecalloc((details)->body_size + (details)->offset, 1) + +#ifndef PURIFY + +/* grab a new thing from the arena's free list, allocating more if necessary. */ +#define new_body_from_arena(xpv, root_index, type_meta) \ + STMT_START { \ + void ** const r3wt = &PL_body_roots[root_index]; \ + xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \ + ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ root_index, \ + type_meta.body_size,\ + type_meta.arena_size)); \ + *(r3wt) = *(void**)(xpv); \ + } STMT_END + +PERL_STATIC_INLINE void * +S_new_body(pTHX_ const svtype sv_type) +{ + void *xpv; + new_body_from_arena(xpv, sv_type, bodies_by_type[sv_type]); + return xpv; +} + +#endif + +static const struct body_details fake_rv = + { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 }; + +static const struct body_details fake_hv_with_aux = + /* The SVt_IV arena is used for (larger) PVHV bodies. */ + { sizeof(ALIGNED_TYPE_NAME(XPVHV_WITH_AUX)), + copy_length(XPVHV, xhv_max), + 0, + SVt_PVHV, TRUE, NONV, HASARENA, + FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV_WITH_AUX))) }; + +/* +=for apidoc newSV_type + +Creates a new SV, of the type specified. The reference count for the new SV +is set to 1. + +=cut +*/ + +PERL_STATIC_INLINE SV * +Perl_newSV_type(pTHX_ const svtype type) +{ + SV *sv; + void* new_body; + const struct body_details *type_details; + + new_SV(sv); + + type_details = bodies_by_type + type; + + SvFLAGS(sv) &= ~SVTYPEMASK; + SvFLAGS(sv) |= type; + + switch (type) { + case SVt_NULL: + break; + case SVt_IV: + SET_SVANY_FOR_BODYLESS_IV(sv); + SvIV_set(sv, 0); + break; + case SVt_NV: +#if NVSIZE <= IVSIZE + SET_SVANY_FOR_BODYLESS_NV(sv); +#else + SvANY(sv) = new_XNV(); +#endif + SvNV_set(sv, 0); + break; + case SVt_PVHV: + case SVt_PVAV: + assert(type_details->body_size); + +#ifndef PURIFY + assert(type_details->arena); + assert(type_details->arena_size); + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + /* xpvav and xpvhv have no offset, so no need to adjust new_body */ + assert(!(type_details->offset)); +#else + /* We always allocated the full length item with PURIFY. To do this + we fake things so that arena is false for all 16 types.. */ + new_body = new_NOARENAZ(type_details); +#endif + SvANY(sv) = new_body; + + SvSTASH_set(sv, NULL); + SvMAGIC_set(sv, NULL); + + if (type == SVt_PVAV) { + AvFILLp(sv) = -1; + AvMAX(sv) = -1; + AvALLOC(sv) = NULL; + + AvREAL_only(sv); + } else { + HvTOTALKEYS(sv) = 0; + /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */ + HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX; + + assert(!SvOK(sv)); + SvOK_off(sv); +#ifndef NODEFAULT_SHAREKEYS + HvSHAREKEYS_on(sv); /* key-sharing on by default */ +#endif + /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */ + HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX; + } + + sv->sv_u.svu_array = NULL; /* or svu_hash */ + break; + + case SVt_PVIV: + case SVt_PVIO: + case SVt_PVGV: + case SVt_PVCV: + case SVt_PVLV: + case SVt_INVLIST: + case SVt_REGEXP: + case SVt_PVMG: + case SVt_PVNV: + case SVt_PV: + /* For a type known at compile time, it should be possible for the + * compiler to deduce the value of (type_details->arena), resolve + * that branch below, and inline the relevant values from + * bodies_by_type. Except, at least for gcc, it seems not to do that. + * We help it out here with two deviations from sv_upgrade: + * (1) Minor rearrangement here, so that PVFM - the only type at this + * point not to be allocated from an array appears last, not PV. + * (2) The ASSUME() statement here for everything that isn't PVFM. + * Obviously this all only holds as long as it's a true reflection of + * the bodies_by_type lookup table. */ +#ifndef PURIFY + ASSUME(type_details->arena); +#endif + /* FALLTHROUGH */ + case SVt_PVFM: + + assert(type_details->body_size); + /* We always allocated the full length item with PURIFY. To do this + we fake things so that arena is false for all 16 types.. */ +#ifndef PURIFY + if(type_details->arena) { + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + Zero(new_body, type_details->body_size, char); + new_body = ((char *)new_body) - type_details->offset; + } else +#endif + { + new_body = new_NOARENAZ(type_details); + } + SvANY(sv) = new_body; + + if (UNLIKELY(type == SVt_PVIO)) { + IO * const io = MUTABLE_IO(sv); + GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV); + + SvOBJECT_on(io); + /* Clear the stashcache because a new IO could overrule a package + name */ + DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n")); + hv_clear(PL_stashcache); + + SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); + IoPAGE_LEN(sv) = 60; + } + + sv->sv_u.svu_rv = NULL; + break; + default: + Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", + (unsigned long)type); + } + + return sv; +} + +/* + * ex: set ts=8 sts=4 sw=4 et: + */ |