diff --git a/MANIFEST b/MANIFEST index ac9456dd3c92..65716ecbd94c 100644 --- a/MANIFEST +++ b/MANIFEST @@ -188,6 +188,7 @@ 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 +svfix.pl throw away script for fixing Perl_newSV_type bloat taint.c Tainting code TestInit.pm Preamble library for tests thread.h Threading header diff --git a/embed.fnc b/embed.fnc index f0d1dedb1485..5a551899d4db 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2296,9 +2296,43 @@ ARdp |SV * |newSVsv_flags |NULLOK SV * const old \ |I32 flags ARdm |SV * |newSVsv_nomg |NULLOK SV * const old ARdp |SV * |newSV_true -ARdip |SV * |newSV_type |const svtype type AIRdp |SV * |newSV_type_mortal \ |const svtype type +ARdip |SV * |newSV_type_mortalSVt_INVLIST +ARdip |SV * |newSV_type_mortalSVt_IV +ARdip |SV * |newSV_type_mortalSVt_NULL +ARdip |SV * |newSV_type_mortalSVt_NV +ARdip |SV * |newSV_type_mortalSVt_PV +ARdip |SV * |newSV_type_mortalSVt_PVAV +ARdip |SV * |newSV_type_mortalSVt_PVCV +ARdip |SV * |newSV_type_mortalSVt_PVFM +ARdip |SV * |newSV_type_mortalSVt_PVGV +ARdip |SV * |newSV_type_mortalSVt_PVHV +ARdip |SV * |newSV_type_mortalSVt_PVIO +ARdip |SV * |newSV_type_mortalSVt_PVIV +ARdip |SV * |newSV_type_mortalSVt_PVLV +ARdip |SV * |newSV_type_mortalSVt_PVMG +ARdip |SV * |newSV_type_mortalSVt_PVNV +ARdip |SV * |newSV_type_mortalSVt_PVOBJ +ARdip |SV * |newSV_type_mortalSVt_REGEXP +ARdip |SV * |newSV_typeSVt_INVLIST +ARdip |SV * |newSV_typeSVt_IV +ARdip |SV * |newSV_typeSVt_NULL +ARdip |SV * |newSV_typeSVt_NV +ARdip |SV * |newSV_typeSVt_PV +ARdip |SV * |newSV_typeSVt_PVAV +ARdip |SV * |newSV_typeSVt_PVCV +ARdip |SV * |newSV_typeSVt_PVFM +ARdip |SV * |newSV_typeSVt_PVGV +ARdip |SV * |newSV_typeSVt_PVHV +ARdip |SV * |newSV_typeSVt_PVIO +ARdip |SV * |newSV_typeSVt_PVIV +ARdip |SV * |newSV_typeSVt_PVLV +ARdip |SV * |newSV_typeSVt_PVMG +ARdip |SV * |newSV_typeSVt_PVNV +ARdip |SV * |newSV_typeSVt_PVOBJ +ARdip |SV * |newSV_typeSVt_REGEXP +ARdip |SV * |newSV_typeX |const svtype type ARdp |SV * |newSVuv |const UV u ARdpx |OP * |newTRYCATCHOP |I32 flags \ |NN OP *tryblock \ diff --git a/embed.h b/embed.h index 8f890fba4df4..a47d5bb46a6d 100644 --- a/embed.h +++ b/embed.h @@ -427,8 +427,42 @@ # define newSVREF(a) Perl_newSVREF(aTHX_ a) # define newSV_false() Perl_newSV_false(aTHX) # define newSV_true() Perl_newSV_true(aTHX) -# define newSV_type(a) Perl_newSV_type(aTHX_ a) +# define newSV_typeSVt_INVLIST() Perl_newSV_typeSVt_INVLIST(aTHX) +# define newSV_typeSVt_IV() Perl_newSV_typeSVt_IV(aTHX) +# define newSV_typeSVt_NULL() Perl_newSV_typeSVt_NULL(aTHX) +# define newSV_typeSVt_NV() Perl_newSV_typeSVt_NV(aTHX) +# define newSV_typeSVt_PV() Perl_newSV_typeSVt_PV(aTHX) +# define newSV_typeSVt_PVAV() Perl_newSV_typeSVt_PVAV(aTHX) +# define newSV_typeSVt_PVCV() Perl_newSV_typeSVt_PVCV(aTHX) +# define newSV_typeSVt_PVFM() Perl_newSV_typeSVt_PVFM(aTHX) +# define newSV_typeSVt_PVGV() Perl_newSV_typeSVt_PVGV(aTHX) +# define newSV_typeSVt_PVHV() Perl_newSV_typeSVt_PVHV(aTHX) +# define newSV_typeSVt_PVIO() Perl_newSV_typeSVt_PVIO(aTHX) +# define newSV_typeSVt_PVIV() Perl_newSV_typeSVt_PVIV(aTHX) +# define newSV_typeSVt_PVLV() Perl_newSV_typeSVt_PVLV(aTHX) +# define newSV_typeSVt_PVMG() Perl_newSV_typeSVt_PVMG(aTHX) +# define newSV_typeSVt_PVNV() Perl_newSV_typeSVt_PVNV(aTHX) +# define newSV_typeSVt_PVOBJ() Perl_newSV_typeSVt_PVOBJ(aTHX) +# define newSV_typeSVt_REGEXP() Perl_newSV_typeSVt_REGEXP(aTHX) +# define newSV_typeX(a) Perl_newSV_typeX(aTHX_ a) # define newSV_type_mortal(a) Perl_newSV_type_mortal(aTHX_ a) +# define newSV_type_mortalSVt_INVLIST() Perl_newSV_type_mortalSVt_INVLIST(aTHX) +# define newSV_type_mortalSVt_IV() Perl_newSV_type_mortalSVt_IV(aTHX) +# define newSV_type_mortalSVt_NULL() Perl_newSV_type_mortalSVt_NULL(aTHX) +# define newSV_type_mortalSVt_NV() Perl_newSV_type_mortalSVt_NV(aTHX) +# define newSV_type_mortalSVt_PV() Perl_newSV_type_mortalSVt_PV(aTHX) +# define newSV_type_mortalSVt_PVAV() Perl_newSV_type_mortalSVt_PVAV(aTHX) +# define newSV_type_mortalSVt_PVCV() Perl_newSV_type_mortalSVt_PVCV(aTHX) +# define newSV_type_mortalSVt_PVFM() Perl_newSV_type_mortalSVt_PVFM(aTHX) +# define newSV_type_mortalSVt_PVGV() Perl_newSV_type_mortalSVt_PVGV(aTHX) +# define newSV_type_mortalSVt_PVHV() Perl_newSV_type_mortalSVt_PVHV(aTHX) +# define newSV_type_mortalSVt_PVIO() Perl_newSV_type_mortalSVt_PVIO(aTHX) +# define newSV_type_mortalSVt_PVIV() Perl_newSV_type_mortalSVt_PVIV(aTHX) +# define newSV_type_mortalSVt_PVLV() Perl_newSV_type_mortalSVt_PVLV(aTHX) +# define newSV_type_mortalSVt_PVMG() Perl_newSV_type_mortalSVt_PVMG(aTHX) +# define newSV_type_mortalSVt_PVNV() Perl_newSV_type_mortalSVt_PVNV(aTHX) +# define newSV_type_mortalSVt_PVOBJ() Perl_newSV_type_mortalSVt_PVOBJ(aTHX) +# define newSV_type_mortalSVt_REGEXP() Perl_newSV_type_mortalSVt_REGEXP(aTHX) # define newSVbool(a) Perl_newSVbool(aTHX_ a) # define newSVhek(a) Perl_newSVhek(aTHX_ a) # define newSVhek_mortal(a) Perl_newSVhek_mortal(aTHX_ a) diff --git a/gv.c b/gv.c index e0a3ef88ba95..a144bf718e17 100644 --- a/gv.c +++ b/gv.c @@ -58,6 +58,7 @@ GV * Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) { SV **where; + static char saw [20] = {0}; if ( !gv @@ -94,7 +95,39 @@ Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) if (!*where) { - *where = newSV_type(type); + if(type == SVt_PVHV) { + *where = newSV_type(SVt_PVHV); + } + else if(type == SVt_PVAV) { + *where = newSV_type(SVt_PVAV); + } + else if(type == SVt_PVMG) { + *where = newSV_type(SVt_PVMG); + } + else if(type == SVt_PVIO) { + *where = newSV_type(SVt_PVIO); + } + else if(type == SVt_PV) { + *where = newSV_type(SVt_PV); + } + else if (type == SVt_PVGV) { + *where = newSV_type(SVt_PVGV); + } + else if(type == SVt_NULL) { + *where = newSV_type(SVt_NULL); + } + // else if(type == ) { + // *where = newSV_type(); + // } + else { + if(!saw[type]) { + //__debugbreak(); + saw[type] = 1; + } + *where = Perl_newSV_typeX(aTHX_ type); + } + + if ( type == SVt_PVAV && memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA")) { @@ -577,7 +610,7 @@ S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type) case SVt_PVGV: break; default: - if(GvSVn(gv)) { + if(GvSVnt(gv,sv_type)) { /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13 If we just cast GvSVn(gv) to void, it ignores evaluating it for its side effect */ @@ -2330,16 +2363,16 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, storeparen: /* Flag the capture variables with a NULL mg_ptr Use mg_len for the array index to lookup. */ - sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren); + sv_magic(GvSVnt(gv, SVt_PVMG), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren); break; case ':': /* $: */ - sv_setpv(GvSVn(gv),PL_chopset); + sv_setpv(GvSVnt(gv, SVt_PVMG),PL_chopset); goto magicalize; case '?': /* $? */ #ifdef COMPLEX_STATUS - SvUPGRADE(GvSVn(gv), SVt_PVLV); + SvUPGRADE(GvSVnt(gv, SVt_PVLV), SVt_PVLV); #endif goto magicalize; @@ -2347,7 +2380,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, GvMULTI_on(gv); /* If %! has been used, automatically load Errno.pm. */ - sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); + sv_magic(GvSVnt(gv,SVt_PVMG), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); /* magicalization must be done before require_tie_mod_s is called */ if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) @@ -2358,8 +2391,9 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, case '+': /* $+, %+, @+ */ GvMULTI_on(gv); /* no used once warnings here */ { /* $- $+ */ - sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); - if (*name == '+') + SV* svplusminus = GvSVnt(gv, SVt_PVMG); + sv_magic(svplusminus, MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); + if (*name == '+') SvREADONLY_on(GvSVn(gv)); } { /* %- %+ */ @@ -2388,7 +2422,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, goto magicalize; case '\023': /* $^S */ ro_magicalize: - SvREADONLY_on(GvSVn(gv)); + SvREADONLY_on(GvSVnt(gv,SVt_PVMG)); /* FALLTHROUGH */ case '0': /* $0 */ case '^': /* $^ */ @@ -2417,14 +2451,14 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, case '\024': /* $^T */ case '\027': /* $^W */ magicalize: - sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); + sv_magic(GvSVnt(gv,SVt_PVMG), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); break; case '\014': /* $^L */ - sv_setpvs(GvSVn(gv),"\f"); + sv_setpvs(GvSVnt(gv, SVt_PV),"\f"); break; case ';': /* $; */ - sv_setpvs(GvSVn(gv),"\034"); + sv_setpvs(GvSVnt(gv, SVt_PV),"\034"); break; case ']': /* $] */ { diff --git a/gv.h b/gv.h index 4b13e7df26e9..31fa415a0d09 100644 --- a/gv.h +++ b/gv.h @@ -101,6 +101,17 @@ L. =for apidoc Am|SV*|GvSVn|GV* gv Like C>, but creates an empty scalar if none already exists. +=for apidoc Am|SV*|GvSVnt|GV* gv|svtype sv_type +Like C>, but creates an empty scalar whose type is already upgraded +to the requested type if none already exists. Note, if there is an existing +scalar already stored in the GV, its type is NOT upgraded, so you still must +do an C unless you are absolutly the scalar slot in the GV was +empty before, or if you allocated or created the GV immediatly before. +Note, all the I functions do all necessary C type +logic checks for you. This macro exists to skip a 2nd pass through the +I allocator subsystem. That 2nd pass skipped is the slow path of +C and swapping SV body types in the type upgrade. + =for apidoc Am|AV*|GvAV|GV* gv Return the AV from the GV. @@ -121,8 +132,12 @@ Return the CV from the GV. #define GvSVn(gv) (*(GvGP(gv)->gp_sv ? \ &(GvGP(gv)->gp_sv) : \ &(GvGP(gv_SVadd(gv))->gp_sv))) +#define GvSVnt(_gv,_sv_type) (*(GvGP(_gv)->gp_sv ? \ + &(GvGP(_gv)->gp_sv) : \ + &(GvGP(gv_SVadd_type(_gv,_sv_type))->gp_sv))) #else #define GvSVn(gv) GvSV(gv) +#define GvSVnt(_gv,_sv_type) (((void)SvUPGRADE(GvSV(_gv),_sv_type)),GvSV(_gv)) #endif #define GvREFCNT(gv) (GvGP(gv)->gp_refcnt) @@ -347,6 +362,7 @@ Make sure there is a slot of the given type (AV, HV, IO, SV) in the GV C. #define gv_HVadd(gv) gv_add_by_type((gv), SVt_PVHV) #define gv_IOadd(gv) gv_add_by_type((gv), SVt_PVIO) #define gv_SVadd(gv) gv_add_by_type((gv), SVt_NULL) +#define gv_SVadd_type(_gv,_sv_type) gv_add_by_type((_gv), (_sv_type)) /* * ex: set ts=8 sts=4 sw=4 et: diff --git a/inline.h b/inline.h index 6bc22831f5ef..27020c5a1298 100644 --- a/inline.h +++ b/inline.h @@ -43,6 +43,11 @@ SOFTWARE. /* ------------------------------- av.h ------------------------------- */ +#undef newSV_type +#define newSV_type(ty) Perl_newSV_type##ty(aTHX) +#undef newSV_type_mortal +#define newSV_type_mortal(ty) Perl_newSV_type_mortal##ty(aTHX) + /* =for apidoc_section $AV =for apidoc av_count diff --git a/pad.c b/pad.c index 9b943b1158e4..1069a717eee5 100644 --- a/pad.c +++ b/pad.c @@ -2219,7 +2219,19 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned) assert(!CvUNIQUE(proto)); - if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto))); + if (!cv) { + // if(SvTYPE(proto) != SVt_PVCV && SvTYPE(proto) != SVt_PVFM ) + // __debugbreak(); + if (SvTYPE(proto) == SVt_PVCV) { + cv = MUTABLE_CV(newSV_type(SVt_PVCV)); + } + else if(SvTYPE(proto) == SVt_PVFM) { + cv = MUTABLE_CV(newSV_type(SVt_PVFM)); + } + else { + croak("panic: S_cv_clone strange SV %u", SvTYPE(proto)); + } + } CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC |CVf_SLABBED); CvCLONED_on(cv); diff --git a/pp.c b/pp.c index 06de422adbf7..b7cc459d6921 100644 --- a/pp.c +++ b/pp.c @@ -5982,10 +5982,9 @@ PP(pp_emptyavhv) { OP * const op = PL_op; SV * rv; - SV * const sv = MUTABLE_SV( newSV_type( - (op->op_private & OPpEMPTYAVHV_IS_HV) ? - SVt_PVHV : - SVt_PVAV ) ); + SV * const sv = MUTABLE_SV( (op->op_private & OPpEMPTYAVHV_IS_HV) + ? newSV_type(SVt_PVHV) + : newSV_type(SVt_PVAV) ); /* Is it an assignment, just a stack push, or both?*/ if (op->op_private & OPpTARGET_MY) { diff --git a/pp_hot.c b/pp_hot.c index 4f1e54711f22..fffb763174fd 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -5995,8 +5995,10 @@ Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass) * SvTYPE(sv), where that is a SVt_PVNV or below. It is * more efficient to create such types directly than * upgrade to them via sv_upgrade() within sv_setsv_flags. */ - SV *newsv = (SvTYPE(sv) <= SVt_PVNV) - ? newSV_type(SvTYPE(sv)) + SV *newsv = SvTYPE(sv) == SVt_IV ? newSV_type(SVt_IV) +#if NVSIZE <= IVSIZE + : SvTYPE(sv) == SVt_NV ? newSV_type(SVt_NV) +#endif : newSV_type(SVt_NULL); PL_tmps_stack[++PL_tmps_ix] = *tmps_basep; diff --git a/proto.h b/proto.h index 65fe5c5bd68c..8ba1d0b407a8 100644 --- a/proto.h +++ b/proto.h @@ -9839,9 +9839,94 @@ Perl_newRV_noinc(pTHX_ SV * const tmpRef) assert(tmpRef) PERL_STATIC_INLINE SV * -Perl_newSV_type(pTHX_ const svtype type) +Perl_newSV_typeSVt_INVLIST(pTHX) __attribute__warn_unused_result__; -# define PERL_ARGS_ASSERT_NEWSV_TYPE +# define PERL_ARGS_ASSERT_NEWSV_TYPESVT_INVLIST + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_IV(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPESVT_IV + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_NULL(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPESVT_NULL + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_NV(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPESVT_NV + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PV(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPESVT_PV + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVAV(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPESVT_PVAV + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVCV(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPESVT_PVCV + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVFM(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPESVT_PVFM + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVGV(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPESVT_PVGV + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVHV(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPESVT_PVHV + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVIO(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPESVT_PVIO + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVIV(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPESVT_PVIV + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVLV(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPESVT_PVLV + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVMG(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPESVT_PVMG + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVNV(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPESVT_PVNV + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVOBJ(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPESVT_PVOBJ + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_REGEXP(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPESVT_REGEXP + +PERL_STATIC_INLINE SV * +Perl_newSV_typeX(pTHX_ const svtype type) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPEX PERL_STATIC_FORCE_INLINE SV * Perl_newSV_type_mortal(pTHX_ const svtype type) @@ -9849,6 +9934,91 @@ Perl_newSV_type_mortal(pTHX_ const svtype type) __attribute__always_inline__; # define PERL_ARGS_ASSERT_NEWSV_TYPE_MORTAL +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_INVLIST(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPE_MORTALSVT_INVLIST + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_IV(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPE_MORTALSVT_IV + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_NULL(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPE_MORTALSVT_NULL + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_NV(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPE_MORTALSVT_NV + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PV(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPE_MORTALSVT_PV + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVAV(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPE_MORTALSVT_PVAV + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVCV(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPE_MORTALSVT_PVCV + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVFM(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPE_MORTALSVT_PVFM + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVGV(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPE_MORTALSVT_PVGV + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVHV(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPE_MORTALSVT_PVHV + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVIO(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPE_MORTALSVT_PVIO + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVIV(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPE_MORTALSVT_PVIV + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVLV(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPE_MORTALSVT_PVLV + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVMG(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPE_MORTALSVT_PVMG + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVNV(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPE_MORTALSVT_PVNV + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVOBJ(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPE_MORTALSVT_PVOBJ + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_REGEXP(pTHX) + __attribute__warn_unused_result__; +# define PERL_ARGS_ASSERT_NEWSV_TYPE_MORTALSVT_REGEXP + PERL_STATIC_INLINE SV * Perl_new_sv(pTHX_ const char *file, int line, const char *func); # define PERL_ARGS_ASSERT_NEW_SV \ diff --git a/scope.c b/scope.c index 47cf4a3473b1..c9d9fa817e12 100644 --- a/scope.c +++ b/scope.c @@ -583,7 +583,7 @@ Perl_save_bool(pTHX_ bool *boolp) PERL_ARGS_ASSERT_SAVE_BOOL; SS_ADD_PTR(boolp); - SS_ADD_UV(SAVEt_BOOL | (*boolp << 8)); + SS_ADD_UV(SAVEt_BOOL | (((UV)((bool)(*boolp))) << 8)); SS_ADD_END(2); } @@ -1302,7 +1302,7 @@ Perl_leave_scope(pTHX_ I32 base) case SAVEt_BOOL: /* bool reference */ a0 = ap[0]; - *(bool*)a0.any_ptr = cBOOL(uv >> 8); + *((bool*)a0.any_ptr) = cBOOL((bool)((UV)uv >> 8)); #ifdef NO_TAINT_SUPPORT PERL_UNUSED_VAR(was); #else @@ -1312,7 +1312,7 @@ Perl_leave_scope(pTHX_ I32 base) * restore it when we exit this routine. Note that this won't * work if this value was saved in a wider-than necessary type, * such as I32 */ - was = *(bool*)a0.any_ptr; + was = *((bool*)a0.any_ptr); } #endif break; diff --git a/sv.c b/sv.c index 2de62af3b819..369f28eda21e 100644 --- a/sv.c +++ b/sv.c @@ -29,6 +29,9 @@ #include "EXTERN.h" #define PERL_IN_SV_C +//#if defined(DEBUGGING) +# define WANT_SV_BODY_DETAILS +//#endif #include "perl.h" #include "regcomp.h" #ifdef __VMS @@ -4922,7 +4925,7 @@ Perl_sv_setsv_cow(pTHX_ SV *dsv, SV *ssv) SvUPGRADE(dsv, SVt_COW); } else - dsv = newSV_type(SVt_COW); + dsv = newSV_type(SVt_PV); assert (SvPOK(ssv)); assert (SvPOKp(ssv)); @@ -5438,9 +5441,19 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags) /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous to sv_unglob. We only need it here, so inline it. */ const bool islv = SvTYPE(sv) == SVt_PVLV; - const svtype new_type = - islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV; - SV *const temp = newSV_type(new_type); + svtype new_type; + SV * temp; + if(islv) { + temp = newSV_type(SVt_NULL); + new_type = SVt_NULL; + } else if (SvMAGIC(sv) || SvSTASH(sv)) { + temp = newSV_type(SVt_PVMG); + new_type = SVt_PVMG; + } + else { + temp = newSV_type(SVt_PV); + new_type = SVt_PV; + } regexp *old_rx_body; if (new_type == SVt_PVMG) { @@ -16539,9 +16552,9 @@ Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to) param->flags = 0; param->proto_perl = from; param->new_perl = to; - param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV); + param->stashes = (AV *)Perl_newSV_typeSVt_PVAV(to); AvREAL_off(param->stashes); - param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV); + param->unreferenced = (AV *)Perl_newSV_typeSVt_PVAV(to); if (was != to) { PERL_SET_THX(was); diff --git a/sv_inline.h b/sv_inline.h index a0fe8ec870c2..6a7fecfc0754 100644 --- a/sv_inline.h +++ b/sv_inline.h @@ -179,6 +179,8 @@ ALIGNED_TYPE(XPVOBJ); STRUCT_OFFSET(type, last_member) \ + sizeof (((type*)SvANY((const SV *)0))->last_member) +#ifdef WANT_SV_BODY_DETAILS + static const struct body_details bodies_by_type[] = { /* HEs use this offset for their arena. */ { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 }, @@ -277,9 +279,35 @@ static const struct body_details bodies_by_type[] = { FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVOBJ))) }, }; +#endif + + +#define SVDB_body_size(_a) ((_a)==SVt_NULL?(0):(_a)==SVt_IV?(0):(_a)==SVt_NV?((NVSIZE <= IVSIZE?(0):(sizeof(NV)))):(_a)==SVt_PV?(sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)):(_a)==SVt_INVLIST?(sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)):(_a)==SVt_PVIV?(sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)):(_a)==SVt_PVNV?(sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)):(_a)==SVt_PVMG?(sizeof(XPVMG)):(_a)==SVt_REGEXP?(sizeof(ALIGNED_TYPE_NAME(regexp))):(_a)==SVt_PVGV?(sizeof(ALIGNED_TYPE_NAME(XPVGV))):(_a)==SVt_PVLV?(sizeof(ALIGNED_TYPE_NAME(XPVLV))):(_a)==SVt_PVAV?(sizeof(ALIGNED_TYPE_NAME(XPVAV))):(_a)==SVt_PVHV?(sizeof(ALIGNED_TYPE_NAME(XPVHV))):(_a)==SVt_PVCV?(sizeof(ALIGNED_TYPE_NAME(XPVCV))):(_a)==SVt_PVFM?(sizeof(ALIGNED_TYPE_NAME(XPVFM))):(_a)==SVt_PVIO?(sizeof(ALIGNED_TYPE_NAME(XPVIO))):(sizeof(ALIGNED_TYPE_NAME(XPVOBJ)))) + +#define SVDB_copy(_a) ((_a)==SVt_NULL?(0):(_a)==SVt_IV?(sizeof(IV)):(_a)==SVt_NV?((NVSIZE <= IVSIZE?(sizeof(NV)):(sizeof(NV)))):(_a)==SVt_PV?(copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur)):(_a)==SVt_INVLIST?(copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur)):(_a)==SVt_PVIV?(copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur)):(_a)==SVt_PVNV?(copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur)):(_a)==SVt_PVMG?(copy_length(XPVMG, xnv_u)):(_a)==SVt_REGEXP?(sizeof(regexp)):(_a)==SVt_PVGV?(sizeof(XPVGV)):(_a)==SVt_PVLV?(sizeof(XPVLV)):(_a)==SVt_PVAV?(copy_length(XPVAV, xav_alloc)):(_a)==SVt_PVHV?(copy_length(XPVHV, xhv_max)):(_a)==SVt_PVCV?(sizeof(XPVCV)):(_a)==SVt_PVFM?(sizeof(XPVFM)):(_a)==SVt_PVIO?(sizeof(XPVIO)):(copy_length(XPVOBJ, xobject_fields))) + +#define SVDB_offset(_a) ((_a)==SVt_NULL?(0):(_a)==SVt_IV?(STRUCT_OFFSET(XPVIV, xiv_iv)):(_a)==SVt_NV?((NVSIZE <= IVSIZE?(STRUCT_OFFSET(XPVNV, xnv_u)):(STRUCT_OFFSET(XPVNV, xnv_u)))):(_a)==SVt_PV?(+ STRUCT_OFFSET(XPV, xpv_cur)):(_a)==SVt_INVLIST?(+ STRUCT_OFFSET(XPV, xpv_cur)):(_a)==SVt_PVIV?(+ STRUCT_OFFSET(XPV, xpv_cur)):(_a)==SVt_PVNV?(+ STRUCT_OFFSET(XPV, xpv_cur)):(_a)==SVt_PVMG?(0):(_a)==SVt_REGEXP?(0):(_a)==SVt_PVGV?(0):(_a)==SVt_PVLV?(0):(_a)==SVt_PVAV?(0):(_a)==SVt_PVHV?(0):(_a)==SVt_PVCV?(0):(_a)==SVt_PVFM?(0):(_a)==SVt_PVIO?(0):(0)) + +#define SVDB_type(_a) ((_a)==SVt_NULL?(SVt_NULL):(_a)==SVt_IV?(SVt_IV):(_a)==SVt_NV?((NVSIZE <= IVSIZE?(SVt_NV):(SVt_NV))):(_a)==SVt_PV?(SVt_PV):(_a)==SVt_INVLIST?(SVt_INVLIST):(_a)==SVt_PVIV?(SVt_PVIV):(_a)==SVt_PVNV?(SVt_PVNV):(_a)==SVt_PVMG?(SVt_PVMG):(_a)==SVt_REGEXP?(SVt_REGEXP):(_a)==SVt_PVGV?(SVt_PVGV):(_a)==SVt_PVLV?(SVt_PVLV):(_a)==SVt_PVAV?(SVt_PVAV):(_a)==SVt_PVHV?(SVt_PVHV):(_a)==SVt_PVCV?(SVt_PVCV):(_a)==SVt_PVFM?(SVt_PVFM):(_a)==SVt_PVIO?(SVt_PVIO):(SVt_PVOBJ)) + +#define SVDB_cant_upgrade(_a) ((_a)==SVt_NULL?(FALSE):(_a)==SVt_IV?(FALSE):(_a)==SVt_NV?((NVSIZE <= IVSIZE?(FALSE):(FALSE))):(_a)==SVt_PV?(FALSE):(_a)==SVt_INVLIST?(TRUE):(_a)==SVt_PVIV?(FALSE):(_a)==SVt_PVNV?(FALSE):(_a)==SVt_PVMG?(FALSE):(_a)==SVt_REGEXP?(TRUE):(_a)==SVt_PVGV?(TRUE):(_a)==SVt_PVLV?(TRUE):(_a)==SVt_PVAV?(TRUE):(_a)==SVt_PVHV?(TRUE):(_a)==SVt_PVCV?(TRUE):(_a)==SVt_PVFM?(TRUE):(_a)==SVt_PVIO?(TRUE):(TRUE)) + +#define SVDB_zero_nv(_a) ((_a)==SVt_NULL?(NONV):(_a)==SVt_IV?(NONV):(_a)==SVt_NV?((NVSIZE <= IVSIZE?(HADNV):(HADNV))):(_a)==SVt_PV?(NONV):(_a)==SVt_INVLIST?(NONV):(_a)==SVt_PVIV?(NONV):(_a)==SVt_PVNV?(HADNV):(_a)==SVt_PVMG?(HADNV):(_a)==SVt_REGEXP?(NONV):(_a)==SVt_PVGV?(HADNV):(_a)==SVt_PVLV?(HADNV):(_a)==SVt_PVAV?(NONV):(_a)==SVt_PVHV?(NONV):(_a)==SVt_PVCV?(NONV):(_a)==SVt_PVFM?(NONV):(_a)==SVt_PVIO?(NONV):(NONV)) + +#define SVDB_arena(_a) ((_a)==SVt_NULL?(NOARENA):(_a)==SVt_IV?(NOARENA):(_a)==SVt_NV?((NVSIZE <= IVSIZE?(NOARENA):(HASARENA))):(_a)==SVt_PV?(HASARENA):(_a)==SVt_INVLIST?(HASARENA):(_a)==SVt_PVIV?(HASARENA):(_a)==SVt_PVNV?(HASARENA):(_a)==SVt_PVMG?(HASARENA):(_a)==SVt_REGEXP?(HASARENA):(_a)==SVt_PVGV?(HASARENA):(_a)==SVt_PVLV?(HASARENA):(_a)==SVt_PVAV?(HASARENA):(_a)==SVt_PVHV?(HASARENA):(_a)==SVt_PVCV?(HASARENA):(_a)==SVt_PVFM?(NOARENA):(_a)==SVt_PVIO?(HASARENA):(HASARENA)) + +#define SVDB_arena_size(_a) ((_a)==SVt_NULL?(0):(_a)==SVt_IV?(0):(_a)==SVt_NV?((NVSIZE <= IVSIZE?(0):(FIT_ARENA(0, sizeof(NV))))):(_a)==SVt_PV?(FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur))):(_a)==SVt_INVLIST?(FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur))):(_a)==SVt_PVIV?(FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur))):(_a)==SVt_PVNV?(FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur))):(_a)==SVt_PVMG?(FIT_ARENA(0, sizeof(XPVMG))):(_a)==SVt_REGEXP?(FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(regexp)))):(_a)==SVt_PVGV?(FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVGV)))):(_a)==SVt_PVLV?(FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVLV)))):(_a)==SVt_PVAV?(FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVAV)))):(_a)==SVt_PVHV?(FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV)))):(_a)==SVt_PVCV?(FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVCV)))):(_a)==SVt_PVFM?(FIT_ARENA(20, sizeof(ALIGNED_TYPE_NAME(XPVFM)))):(_a)==SVt_PVIO?(FIT_ARENA(24, sizeof(ALIGNED_TYPE_NAME(XPVIO)))):(FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVOBJ))))) + + +#ifdef WANT_SV_BODY_DETAILS #define new_body_allocated(sv_type) \ (void *)((char *)S_new_body(aTHX_ sv_type) \ - bodies_by_type[sv_type].offset) +#else +#define new_body_allocated(sv_type) \ + (void *)((char *)S_new_body(aTHX_ sv_type) \ + - SVDB_offset(sv_type) +#endif #ifdef PURIFY #if !(NVSIZE <= IVSIZE) @@ -298,22 +326,37 @@ static const struct body_details bodies_by_type[] = { #define new_XPVNV() new_body_allocated(SVt_PVNV) #define new_XPVMG() new_body_allocated(SVt_PVMG) +#ifdef WANT_SV_BODY_DETAILS #define del_body_by_type(p, type) \ del_body(p + bodies_by_type[(type)].offset, \ &PL_body_roots[(type)]) +#else +#define del_body_by_type(p, type) \ + del_body(p + SVDB_offset(type), \ + &PL_body_roots[(type)]) +#endif #endif /* PURIFY */ /* no arena for you! */ + +#ifdef WANT_SV_BODY_DETAILS #define new_NOARENA(details) \ safemalloc((details)->body_size + (details)->offset) #define new_NOARENAZ(details) \ safecalloc((details)->body_size + (details)->offset, 1) +#else +#define new_NOARENA(_sv_type) \ + safemalloc(SVDB_body_size(_sv_type) + SVDB_offset(_sv_type)) +#define new_NOARENAZ(_sv_type) \ + safecalloc(SVDB_body_size(_sv_type) + SVDB_offset(_sv_type), 1) +#endif #ifndef PURIFY /* grab a new thing from the arena's free list, allocating more if necessary. */ +#ifdef WANT_SV_BODY_DETAILS #define new_body_from_arena(xpv, root_index, type_meta) \ STMT_START { \ void ** const r3wt = &PL_body_roots[root_index]; \ @@ -323,12 +366,27 @@ static const struct body_details bodies_by_type[] = { type_meta.arena_size)); \ *(r3wt) = *(void**)(xpv); \ } STMT_END +#endif + +#define new_body_from_arena_exp(xpv, root_index, _body_size, _arena_size) \ + 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, \ + _body_size,\ + _arena_size)); \ + *(r3wt) = *(void**)(xpv); \ + } STMT_END PERL_STATIC_INLINE void * S_new_body(pTHX_ const svtype sv_type) { void *xpv; +#ifdef WANT_SV_BODY_DETAILS new_body_from_arena(xpv, sv_type, bodies_by_type[sv_type]); +#else + new_body_from_arena_exp(xpv, sv_type, SVDB_body_size(sv_type), SVDB_arena_size(sv_type)); +#endif return xpv; } @@ -346,13 +404,17 @@ static const struct body_details fake_hv_with_aux = FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV_WITH_AUX))) }; /* -=for apidoc newSV_type +=for apidoc newSV_typeX Creates a new SV, of the type specified. The reference count for the new SV is set to 1. =cut */ +#undef newSV_type +#define newSV_type(ty) Perl_newSV_type##ty(aTHX) + +#if 0 PERL_STATIC_INLINE SV * Perl_newSV_type(pTHX_ const svtype type) @@ -398,7 +460,11 @@ Perl_newSV_type(pTHX_ const svtype type) #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.. */ +#ifdef WANT_SV_BODY_DETAILS new_body = new_NOARENAZ(type_details); +#else + new_body = new_NOARENAZ(type); +#endif #endif SvANY(sv) = new_body; @@ -475,7 +541,192 @@ Perl_newSV_type(pTHX_ const svtype type) } else #endif { +#ifdef WANT_SV_BODY_DETAILS new_body = new_NOARENAZ(type_details); +#else + new_body = new_NOARENAZ(type); +#endif + } + 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; +} + +#endif + +PERL_STATIC_INLINE SV * +Perl_newSV_typeX(pTHX_ const svtype type) +{ + + SV *sv; + void* new_body; +#ifdef WANT_SV_BODY_DETAILS + const struct body_details *type_details; +#endif + + new_SV(sv); +#ifdef WANT_SV_BODY_DETAILS + type_details = bodies_by_type + type; +#endif + + 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: + case SVt_PVOBJ: +#ifdef WANT_SV_BODY_DETAILS + assert(type_details->body_size); +#endif + +#ifndef PURIFY +#ifdef WANT_SV_BODY_DETAILS + assert(type_details->arena); + assert(type_details->arena_size); +#endif + /* 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 */ +#ifdef WANT_SV_BODY_DETAILS + assert(type_details->offset); +#endif +#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.. */ +#ifdef WANT_SV_BODY_DETAILS + new_body = new_NOARENAZ(type_details); +#else + new_body = new_NOARENAZ(type); +#endif +#endif + SvANY(sv) = new_body; + + SvSTASH_set(sv, NULL); + SvMAGIC_set(sv, NULL); + + switch(type) { + case SVt_PVAV: + AvFILLp(sv) = -1; + AvMAX(sv) = -1; + AvALLOC(sv) = NULL; + + AvREAL_only(sv); + break; + case SVt_PVHV: + 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; + break; + case SVt_PVOBJ: + ObjectMAXFIELD(sv) = -1; + ObjectFIELDS(sv) = NULL; + break; + default: + NOT_REACHED; + } + + 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 +#ifdef WANT_SV_BODY_DETAILS + ASSUME(type_details->arena); +#endif +#endif + /* FALLTHROUGH */ + case SVt_PVFM: +#ifdef WANT_SV_BODY_DETAILS + assert(type_details->body_size); +#endif + /* 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 +#ifdef WANT_SV_BODY_DETAILS + if(type_details->arena) { +#else + if(SVDB_arena(type)) { +#endif + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); +#ifdef WANT_SV_BODY_DETAILS + Zero(new_body, type_details->body_size, char); + new_body = ((char *)new_body) - type_details->offset; +#else + Zero(new_body, SVDB_body_size(type), char); + new_body = ((char *)new_body) - SVDB_offset(type); +#endif + } else +#endif + { +#ifdef WANT_SV_BODY_DETAILS + new_body = new_NOARENAZ(type_details); +#else + new_body = new_NOARENAZ(type); +#endif } SvANY(sv) = new_body; @@ -520,10 +771,12 @@ at some point in the future.) =cut */ +#if 0 + PERL_STATIC_INLINE SV * Perl_newSV_type_mortal(pTHX_ const svtype type) { - SV *sv = newSV_type(type); + SV *sv = Perl_newSV_type(pTHX_ type); SSize_t ix = ++PL_tmps_ix; if (UNLIKELY(ix >= PL_tmps_max)) ix = Perl_tmps_grow_p(aTHX_ ix); @@ -532,6 +785,7 @@ Perl_newSV_type_mortal(pTHX_ const svtype type) return sv; } +#endif /* The following functions started out in sv.h and then moved to inline.h. They * moved again into this file during the 5.37.x development cycle. */ @@ -858,7 +1112,7 @@ Perl_SvNV_nomg(pTHX_ SV *sv) { PERL_STATIC_INLINE STRLEN S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp) { - PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B; + if (SvGAMAGIC(sv)) { U8 *hopped = utf8_hop((U8 *)pv, pos); if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped); @@ -989,6 +1243,2787 @@ Perl_sv_setpv_freshbuf(pTHX_ SV *const sv) return SvPVX(sv); } + + + + + + + + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_NULL(pTHX) +{ + SV *sv; + void* new_body; + + new_SV(sv); + +#define type SVt_NULL + + 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: + case SVt_PVOBJ: + assert(SVDB_body_size(SVt_NULL)); + +#ifndef PURIFY + assert(SVDB_arena(SVt_NULL)); + assert(SVDB_arena_size(SVt_NULL)); + /* 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(!(SVDB_offset(SVt_NULL))); +#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 = safecalloc(SVDB_body_size(SVt_NULL) + SVDB_offset(SVt_NULL), 1); +#endif + SvANY(sv) = new_body; + + SvSTASH_set(sv, NULL); + SvMAGIC_set(sv, NULL); + + switch(type) { + case SVt_PVAV: + AvFILLp(sv) = -1; + AvMAX(sv) = -1; + AvALLOC(sv) = NULL; + + AvREAL_only(sv); + break; + case SVt_PVHV: + 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; + break; + case SVt_PVOBJ: + ObjectMAXFIELD(sv) = -1; + ObjectFIELDS(sv) = NULL; + break; + default: + NOT_REACHED; + } + + 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 (SVDB_arena(SVt_NULL)), 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(SVDB_arena(SVt_NULL)); +#endif + /* FALLTHROUGH */ + case SVt_PVFM: + + assert(SVDB_body_size(SVt_NULL)); + /* 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(SVDB_arena(SVt_NULL)) { + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + Zero(new_body, SVDB_body_size(SVt_NULL), char); + new_body = ((char *)new_body) - SVDB_offset(SVt_NULL); + } else +#endif + { + new_body = safecalloc(SVDB_body_size(SVt_NULL) + SVDB_offset(SVt_NULL), 1); + } + 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); + } + +#undef type + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_IV(pTHX) +{ + SV *sv; + void* new_body; + + new_SV(sv); + +#define type SVt_IV + + 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: + case SVt_PVOBJ: + assert(SVDB_body_size(SVt_IV)); + +#ifndef PURIFY + assert(SVDB_arena(SVt_IV)); + assert(SVDB_arena_size(SVt_IV)); + /* 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(!(SVDB_offset(SVt_IV))); +#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 = safecalloc(SVDB_body_size(SVt_IV) + SVDB_offset(SVt_IV), 1); +#endif + SvANY(sv) = new_body; + + SvSTASH_set(sv, NULL); + SvMAGIC_set(sv, NULL); + + switch(type) { + case SVt_PVAV: + AvFILLp(sv) = -1; + AvMAX(sv) = -1; + AvALLOC(sv) = NULL; + + AvREAL_only(sv); + break; + case SVt_PVHV: + 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; + break; + case SVt_PVOBJ: + ObjectMAXFIELD(sv) = -1; + ObjectFIELDS(sv) = NULL; + break; + default: + NOT_REACHED; + } + + 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 (SVDB_arena(SVt_IV)), 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(SVDB_arena(SVt_IV)); +#endif + /* FALLTHROUGH */ + case SVt_PVFM: + + assert(SVDB_body_size(SVt_IV)); + /* 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(SVDB_arena(SVt_IV)) { + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + Zero(new_body, SVDB_body_size(SVt_IV), char); + new_body = ((char *)new_body) - SVDB_offset(SVt_IV); + } else +#endif + { + new_body = safecalloc(SVDB_body_size(SVt_IV) + SVDB_offset(SVt_IV), 1); + } + 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); + } + +#undef type + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_NV(pTHX) +{ + SV *sv; + void* new_body; + + new_SV(sv); + +#define type SVt_NV + + 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: + case SVt_PVOBJ: + assert(SVDB_body_size(SVt_NV)); + +#ifndef PURIFY + assert(SVDB_arena(SVt_NV)); + assert(SVDB_arena_size(SVt_NV)); + /* 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(!(SVDB_offset(SVt_NV))); +#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 = safecalloc(SVDB_body_size(SVt_NV) + SVDB_offset(SVt_NV), 1); +#endif + SvANY(sv) = new_body; + + SvSTASH_set(sv, NULL); + SvMAGIC_set(sv, NULL); + + switch(type) { + case SVt_PVAV: + AvFILLp(sv) = -1; + AvMAX(sv) = -1; + AvALLOC(sv) = NULL; + + AvREAL_only(sv); + break; + case SVt_PVHV: + 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; + break; + case SVt_PVOBJ: + ObjectMAXFIELD(sv) = -1; + ObjectFIELDS(sv) = NULL; + break; + default: + NOT_REACHED; + } + + 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 (SVDB_arena(SVt_NV)), 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(SVDB_arena(SVt_NV)); +#endif + /* FALLTHROUGH */ + case SVt_PVFM: + + assert(SVDB_body_size(SVt_NV)); + /* 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(SVDB_arena(SVt_NV)) { + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + Zero(new_body, SVDB_body_size(SVt_NV), char); + new_body = ((char *)new_body) - SVDB_offset(SVt_NV); + } else +#endif + { + new_body = safecalloc(SVDB_body_size(SVt_NV) + SVDB_offset(SVt_NV), 1); + } + 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); + } + +#undef type + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PV(pTHX) +{ + SV *sv; + void* new_body; + + new_SV(sv); + +#define type SVt_PV + + 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: + case SVt_PVOBJ: + assert(SVDB_body_size(SVt_PV)); + +#ifndef PURIFY + assert(SVDB_arena(SVt_PV)); + assert(SVDB_arena_size(SVt_PV)); + /* 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(!(SVDB_offset(SVt_PV))); +#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 = safecalloc(SVDB_body_size(SVt_PV) + SVDB_offset(SVt_PV), 1); +#endif + SvANY(sv) = new_body; + + SvSTASH_set(sv, NULL); + SvMAGIC_set(sv, NULL); + + switch(type) { + case SVt_PVAV: + AvFILLp(sv) = -1; + AvMAX(sv) = -1; + AvALLOC(sv) = NULL; + + AvREAL_only(sv); + break; + case SVt_PVHV: + 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; + break; + case SVt_PVOBJ: + ObjectMAXFIELD(sv) = -1; + ObjectFIELDS(sv) = NULL; + break; + default: + NOT_REACHED; + } + + 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 (SVDB_arena(SVt_PV)), 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(SVDB_arena(SVt_PV)); +#endif + /* FALLTHROUGH */ + case SVt_PVFM: + + assert(SVDB_body_size(SVt_PV)); + /* 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(SVDB_arena(SVt_PV)) { + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + Zero(new_body, SVDB_body_size(SVt_PV), char); + new_body = ((char *)new_body) - SVDB_offset(SVt_PV); + } else +#endif + { + new_body = safecalloc(SVDB_body_size(SVt_PV) + SVDB_offset(SVt_PV), 1); + } + 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); + } + +#undef type + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_INVLIST(pTHX) +{ + SV *sv; + void* new_body; + + new_SV(sv); + +#define type SVt_INVLIST + + 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: + case SVt_PVOBJ: + assert(SVDB_body_size(SVt_INVLIST)); + +#ifndef PURIFY + assert(SVDB_arena(SVt_INVLIST)); + assert(SVDB_arena_size(SVt_INVLIST)); + /* 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(!(SVDB_offset(SVt_INVLIST))); +#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 = safecalloc(SVDB_body_size(SVt_INVLIST) + SVDB_offset(SVt_INVLIST), 1); +#endif + SvANY(sv) = new_body; + + SvSTASH_set(sv, NULL); + SvMAGIC_set(sv, NULL); + + switch(type) { + case SVt_PVAV: + AvFILLp(sv) = -1; + AvMAX(sv) = -1; + AvALLOC(sv) = NULL; + + AvREAL_only(sv); + break; + case SVt_PVHV: + 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; + break; + case SVt_PVOBJ: + ObjectMAXFIELD(sv) = -1; + ObjectFIELDS(sv) = NULL; + break; + default: + NOT_REACHED; + } + + 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 (SVDB_arena(SVt_INVLIST)), 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(SVDB_arena(SVt_INVLIST)); +#endif + /* FALLTHROUGH */ + case SVt_PVFM: + + assert(SVDB_body_size(SVt_INVLIST)); + /* 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(SVDB_arena(SVt_INVLIST)) { + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + Zero(new_body, SVDB_body_size(SVt_INVLIST), char); + new_body = ((char *)new_body) - SVDB_offset(SVt_INVLIST); + } else +#endif + { + new_body = safecalloc(SVDB_body_size(SVt_INVLIST) + SVDB_offset(SVt_INVLIST), 1); + } + 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); + } + +#undef type + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVIV(pTHX) +{ + SV *sv; + void* new_body; + + new_SV(sv); + +#define type SVt_PVIV + + 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: + case SVt_PVOBJ: + assert(SVDB_body_size(SVt_PVIV)); + +#ifndef PURIFY + assert(SVDB_arena(SVt_PVIV)); + assert(SVDB_arena_size(SVt_PVIV)); + /* 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(!(SVDB_offset(SVt_PVIV))); +#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 = safecalloc(SVDB_body_size(SVt_PVIV) + SVDB_offset(SVt_PVIV), 1); +#endif + SvANY(sv) = new_body; + + SvSTASH_set(sv, NULL); + SvMAGIC_set(sv, NULL); + + switch(type) { + case SVt_PVAV: + AvFILLp(sv) = -1; + AvMAX(sv) = -1; + AvALLOC(sv) = NULL; + + AvREAL_only(sv); + break; + case SVt_PVHV: + 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; + break; + case SVt_PVOBJ: + ObjectMAXFIELD(sv) = -1; + ObjectFIELDS(sv) = NULL; + break; + default: + NOT_REACHED; + } + + 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 (SVDB_arena(SVt_PVIV)), 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(SVDB_arena(SVt_PVIV)); +#endif + /* FALLTHROUGH */ + case SVt_PVFM: + + assert(SVDB_body_size(SVt_PVIV)); + /* 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(SVDB_arena(SVt_PVIV)) { + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + Zero(new_body, SVDB_body_size(SVt_PVIV), char); + new_body = ((char *)new_body) - SVDB_offset(SVt_PVIV); + } else +#endif + { + new_body = safecalloc(SVDB_body_size(SVt_PVIV) + SVDB_offset(SVt_PVIV), 1); + } + 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); + } + +#undef type + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVNV(pTHX) +{ + SV *sv; + void* new_body; + + new_SV(sv); + +#define type SVt_PVNV + + 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: + case SVt_PVOBJ: + assert(SVDB_body_size(SVt_PVNV)); + +#ifndef PURIFY + assert(SVDB_arena(SVt_PVNV)); + assert(SVDB_arena_size(SVt_PVNV)); + /* 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(!(SVDB_offset(SVt_PVNV))); +#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 = safecalloc(SVDB_body_size(SVt_PVNV) + SVDB_offset(SVt_PVNV), 1); +#endif + SvANY(sv) = new_body; + + SvSTASH_set(sv, NULL); + SvMAGIC_set(sv, NULL); + + switch(type) { + case SVt_PVAV: + AvFILLp(sv) = -1; + AvMAX(sv) = -1; + AvALLOC(sv) = NULL; + + AvREAL_only(sv); + break; + case SVt_PVHV: + 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; + break; + case SVt_PVOBJ: + ObjectMAXFIELD(sv) = -1; + ObjectFIELDS(sv) = NULL; + break; + default: + NOT_REACHED; + } + + 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 (SVDB_arena(SVt_PVNV)), 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(SVDB_arena(SVt_PVNV)); +#endif + /* FALLTHROUGH */ + case SVt_PVFM: + + assert(SVDB_body_size(SVt_PVNV)); + /* 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(SVDB_arena(SVt_PVNV)) { + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + Zero(new_body, SVDB_body_size(SVt_PVNV), char); + new_body = ((char *)new_body) - SVDB_offset(SVt_PVNV); + } else +#endif + { + new_body = safecalloc(SVDB_body_size(SVt_PVNV) + SVDB_offset(SVt_PVNV), 1); + } + 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); + } + +#undef type + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVMG(pTHX) +{ + SV *sv; + void* new_body; + + new_SV(sv); + +#define type SVt_PVMG + + 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: + case SVt_PVOBJ: + assert(SVDB_body_size(SVt_PVMG)); + +#ifndef PURIFY + assert(SVDB_arena(SVt_PVMG)); + assert(SVDB_arena_size(SVt_PVMG)); + /* 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(!(SVDB_offset(SVt_PVMG))); +#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 = safecalloc(SVDB_body_size(SVt_PVMG) + SVDB_offset(SVt_PVMG), 1); +#endif + SvANY(sv) = new_body; + + SvSTASH_set(sv, NULL); + SvMAGIC_set(sv, NULL); + + switch(type) { + case SVt_PVAV: + AvFILLp(sv) = -1; + AvMAX(sv) = -1; + AvALLOC(sv) = NULL; + + AvREAL_only(sv); + break; + case SVt_PVHV: + 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; + break; + case SVt_PVOBJ: + ObjectMAXFIELD(sv) = -1; + ObjectFIELDS(sv) = NULL; + break; + default: + NOT_REACHED; + } + + 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 (SVDB_arena(SVt_PVMG)), 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(SVDB_arena(SVt_PVMG)); +#endif + /* FALLTHROUGH */ + case SVt_PVFM: + + assert(SVDB_body_size(SVt_PVMG)); + /* 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(SVDB_arena(SVt_PVMG)) { + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + Zero(new_body, SVDB_body_size(SVt_PVMG), char); + new_body = ((char *)new_body) - SVDB_offset(SVt_PVMG); + } else +#endif + { + new_body = safecalloc(SVDB_body_size(SVt_PVMG) + SVDB_offset(SVt_PVMG), 1); + } + 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); + } + +#undef type + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_REGEXP(pTHX) +{ + SV *sv; + void* new_body; + + new_SV(sv); + +#define type SVt_REGEXP + + 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: + case SVt_PVOBJ: + assert(SVDB_body_size(SVt_REGEXP)); + +#ifndef PURIFY + assert(SVDB_arena(SVt_REGEXP)); + assert(SVDB_arena_size(SVt_REGEXP)); + /* 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(!(SVDB_offset(SVt_REGEXP))); +#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 = safecalloc(SVDB_body_size(SVt_REGEXP) + SVDB_offset(SVt_REGEXP), 1); +#endif + SvANY(sv) = new_body; + + SvSTASH_set(sv, NULL); + SvMAGIC_set(sv, NULL); + + switch(type) { + case SVt_PVAV: + AvFILLp(sv) = -1; + AvMAX(sv) = -1; + AvALLOC(sv) = NULL; + + AvREAL_only(sv); + break; + case SVt_PVHV: + 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; + break; + case SVt_PVOBJ: + ObjectMAXFIELD(sv) = -1; + ObjectFIELDS(sv) = NULL; + break; + default: + NOT_REACHED; + } + + 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 (SVDB_arena(SVt_REGEXP)), 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(SVDB_arena(SVt_REGEXP)); +#endif + /* FALLTHROUGH */ + case SVt_PVFM: + + assert(SVDB_body_size(SVt_REGEXP)); + /* 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(SVDB_arena(SVt_REGEXP)) { + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + Zero(new_body, SVDB_body_size(SVt_REGEXP), char); + new_body = ((char *)new_body) - SVDB_offset(SVt_REGEXP); + } else +#endif + { + new_body = safecalloc(SVDB_body_size(SVt_REGEXP) + SVDB_offset(SVt_REGEXP), 1); + } + 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); + } + +#undef type + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVGV(pTHX) +{ + SV *sv; + void* new_body; + + new_SV(sv); + +#define type SVt_PVGV + + 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: + case SVt_PVOBJ: + assert(SVDB_body_size(SVt_PVGV)); + +#ifndef PURIFY + assert(SVDB_arena(SVt_PVGV)); + assert(SVDB_arena_size(SVt_PVGV)); + /* 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(!(SVDB_offset(SVt_PVGV))); +#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 = safecalloc(SVDB_body_size(SVt_PVGV) + SVDB_offset(SVt_PVGV), 1); +#endif + SvANY(sv) = new_body; + + SvSTASH_set(sv, NULL); + SvMAGIC_set(sv, NULL); + + switch(type) { + case SVt_PVAV: + AvFILLp(sv) = -1; + AvMAX(sv) = -1; + AvALLOC(sv) = NULL; + + AvREAL_only(sv); + break; + case SVt_PVHV: + 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; + break; + case SVt_PVOBJ: + ObjectMAXFIELD(sv) = -1; + ObjectFIELDS(sv) = NULL; + break; + default: + NOT_REACHED; + } + + 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 (SVDB_arena(SVt_PVGV)), 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(SVDB_arena(SVt_PVGV)); +#endif + /* FALLTHROUGH */ + case SVt_PVFM: + + assert(SVDB_body_size(SVt_PVGV)); + /* 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(SVDB_arena(SVt_PVGV)) { + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + Zero(new_body, SVDB_body_size(SVt_PVGV), char); + new_body = ((char *)new_body) - SVDB_offset(SVt_PVGV); + } else +#endif + { + new_body = safecalloc(SVDB_body_size(SVt_PVGV) + SVDB_offset(SVt_PVGV), 1); + } + 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); + } + +#undef type + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVLV(pTHX) +{ + SV *sv; + void* new_body; + + new_SV(sv); + +#define type SVt_PVLV + + 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: + case SVt_PVOBJ: + assert(SVDB_body_size(SVt_PVLV)); + +#ifndef PURIFY + assert(SVDB_arena(SVt_PVLV)); + assert(SVDB_arena_size(SVt_PVLV)); + /* 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(!(SVDB_offset(SVt_PVLV))); +#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 = safecalloc(SVDB_body_size(SVt_PVLV) + SVDB_offset(SVt_PVLV), 1); +#endif + SvANY(sv) = new_body; + + SvSTASH_set(sv, NULL); + SvMAGIC_set(sv, NULL); + + switch(type) { + case SVt_PVAV: + AvFILLp(sv) = -1; + AvMAX(sv) = -1; + AvALLOC(sv) = NULL; + + AvREAL_only(sv); + break; + case SVt_PVHV: + 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; + break; + case SVt_PVOBJ: + ObjectMAXFIELD(sv) = -1; + ObjectFIELDS(sv) = NULL; + break; + default: + NOT_REACHED; + } + + 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 (SVDB_arena(SVt_PVLV)), 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(SVDB_arena(SVt_PVLV)); +#endif + /* FALLTHROUGH */ + case SVt_PVFM: + + assert(SVDB_body_size(SVt_PVLV)); + /* 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(SVDB_arena(SVt_PVLV)) { + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + Zero(new_body, SVDB_body_size(SVt_PVLV), char); + new_body = ((char *)new_body) - SVDB_offset(SVt_PVLV); + } else +#endif + { + new_body = safecalloc(SVDB_body_size(SVt_PVLV) + SVDB_offset(SVt_PVLV), 1); + } + 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); + } + +#undef type + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVAV(pTHX) +{ + SV *sv; + void* new_body; + + new_SV(sv); + +#define type SVt_PVAV + + 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: + case SVt_PVOBJ: + assert(SVDB_body_size(SVt_PVAV)); + +#ifndef PURIFY + assert(SVDB_arena(SVt_PVAV)); + assert(SVDB_arena_size(SVt_PVAV)); + /* 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(!(SVDB_offset(SVt_PVAV))); +#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 = safecalloc(SVDB_body_size(SVt_PVAV) + SVDB_offset(SVt_PVAV), 1); +#endif + SvANY(sv) = new_body; + + SvSTASH_set(sv, NULL); + SvMAGIC_set(sv, NULL); + + switch(type) { + case SVt_PVAV: + AvFILLp(sv) = -1; + AvMAX(sv) = -1; + AvALLOC(sv) = NULL; + + AvREAL_only(sv); + break; + case SVt_PVHV: + 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; + break; + case SVt_PVOBJ: + ObjectMAXFIELD(sv) = -1; + ObjectFIELDS(sv) = NULL; + break; + default: + NOT_REACHED; + } + + 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 (SVDB_arena(SVt_PVAV)), 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(SVDB_arena(SVt_PVAV)); +#endif + /* FALLTHROUGH */ + case SVt_PVFM: + + assert(SVDB_body_size(SVt_PVAV)); + /* 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(SVDB_arena(SVt_PVAV)) { + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + Zero(new_body, SVDB_body_size(SVt_PVAV), char); + new_body = ((char *)new_body) - SVDB_offset(SVt_PVAV); + } else +#endif + { + new_body = safecalloc(SVDB_body_size(SVt_PVAV) + SVDB_offset(SVt_PVAV), 1); + } + 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); + } + +#undef type + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVHV(pTHX) +{ + SV *sv; + void* new_body; + + new_SV(sv); + +#define type SVt_PVHV + + 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: + case SVt_PVOBJ: + assert(SVDB_body_size(SVt_PVHV)); + +#ifndef PURIFY + assert(SVDB_arena(SVt_PVHV)); + assert(SVDB_arena_size(SVt_PVHV)); + /* 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(!(SVDB_offset(SVt_PVHV))); +#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 = safecalloc(SVDB_body_size(SVt_PVHV) + SVDB_offset(SVt_PVHV), 1); +#endif + SvANY(sv) = new_body; + + SvSTASH_set(sv, NULL); + SvMAGIC_set(sv, NULL); + + switch(type) { + case SVt_PVAV: + AvFILLp(sv) = -1; + AvMAX(sv) = -1; + AvALLOC(sv) = NULL; + + AvREAL_only(sv); + break; + case SVt_PVHV: + 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; + break; + case SVt_PVOBJ: + ObjectMAXFIELD(sv) = -1; + ObjectFIELDS(sv) = NULL; + break; + default: + NOT_REACHED; + } + + 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 (SVDB_arena(SVt_PVHV)), 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(SVDB_arena(SVt_PVHV)); +#endif + /* FALLTHROUGH */ + case SVt_PVFM: + + assert(SVDB_body_size(SVt_PVHV)); + /* 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(SVDB_arena(SVt_PVHV)) { + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + Zero(new_body, SVDB_body_size(SVt_PVHV), char); + new_body = ((char *)new_body) - SVDB_offset(SVt_PVHV); + } else +#endif + { + new_body = safecalloc(SVDB_body_size(SVt_PVHV) + SVDB_offset(SVt_PVHV), 1); + } + 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); + } + +#undef type + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVCV(pTHX) +{ + SV *sv; + void* new_body; + + new_SV(sv); + +#define type SVt_PVCV + + 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: + case SVt_PVOBJ: + assert(SVDB_body_size(SVt_PVCV)); + +#ifndef PURIFY + assert(SVDB_arena(SVt_PVCV)); + assert(SVDB_arena_size(SVt_PVCV)); + /* 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(!(SVDB_offset(SVt_PVCV))); +#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 = safecalloc(SVDB_body_size(SVt_PVCV) + SVDB_offset(SVt_PVCV), 1); +#endif + SvANY(sv) = new_body; + + SvSTASH_set(sv, NULL); + SvMAGIC_set(sv, NULL); + + switch(type) { + case SVt_PVAV: + AvFILLp(sv) = -1; + AvMAX(sv) = -1; + AvALLOC(sv) = NULL; + + AvREAL_only(sv); + break; + case SVt_PVHV: + 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; + break; + case SVt_PVOBJ: + ObjectMAXFIELD(sv) = -1; + ObjectFIELDS(sv) = NULL; + break; + default: + NOT_REACHED; + } + + 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 (SVDB_arena(SVt_PVCV)), 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(SVDB_arena(SVt_PVCV)); +#endif + /* FALLTHROUGH */ + case SVt_PVFM: + + assert(SVDB_body_size(SVt_PVCV)); + /* 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(SVDB_arena(SVt_PVCV)) { + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + Zero(new_body, SVDB_body_size(SVt_PVCV), char); + new_body = ((char *)new_body) - SVDB_offset(SVt_PVCV); + } else +#endif + { + new_body = safecalloc(SVDB_body_size(SVt_PVCV) + SVDB_offset(SVt_PVCV), 1); + } + 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); + } + +#undef type + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVFM(pTHX) +{ + SV *sv; + void* new_body; + + new_SV(sv); + +#define type SVt_PVFM + + 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: + case SVt_PVOBJ: + assert(SVDB_body_size(SVt_PVFM)); + +#ifndef PURIFY + assert(SVDB_arena(SVt_PVFM)); + assert(SVDB_arena_size(SVt_PVFM)); + /* 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(!(SVDB_offset(SVt_PVFM))); +#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 = safecalloc(SVDB_body_size(SVt_PVFM) + SVDB_offset(SVt_PVFM), 1); +#endif + SvANY(sv) = new_body; + + SvSTASH_set(sv, NULL); + SvMAGIC_set(sv, NULL); + + switch(type) { + case SVt_PVAV: + AvFILLp(sv) = -1; + AvMAX(sv) = -1; + AvALLOC(sv) = NULL; + + AvREAL_only(sv); + break; + case SVt_PVHV: + 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; + break; + case SVt_PVOBJ: + ObjectMAXFIELD(sv) = -1; + ObjectFIELDS(sv) = NULL; + break; + default: + NOT_REACHED; + } + + 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 (SVDB_arena(SVt_PVFM)), 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(SVDB_arena(SVt_PVFM)); +#endif + /* FALLTHROUGH */ + case SVt_PVFM: + + assert(SVDB_body_size(SVt_PVFM)); + /* 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(SVDB_arena(SVt_PVFM)) { + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + Zero(new_body, SVDB_body_size(SVt_PVFM), char); + new_body = ((char *)new_body) - SVDB_offset(SVt_PVFM); + } else +#endif + { + new_body = safecalloc(SVDB_body_size(SVt_PVFM) + SVDB_offset(SVt_PVFM), 1); + } + 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); + } + +#undef type + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVIO(pTHX) +{ + SV *sv; + void* new_body; + + new_SV(sv); + +#define type SVt_PVIO + + 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: + case SVt_PVOBJ: + assert(SVDB_body_size(SVt_PVIO)); + +#ifndef PURIFY + assert(SVDB_arena(SVt_PVIO)); + assert(SVDB_arena_size(SVt_PVIO)); + /* 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(!(SVDB_offset(SVt_PVIO))); +#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 = safecalloc(SVDB_body_size(SVt_PVIO) + SVDB_offset(SVt_PVIO), 1); +#endif + SvANY(sv) = new_body; + + SvSTASH_set(sv, NULL); + SvMAGIC_set(sv, NULL); + + switch(type) { + case SVt_PVAV: + AvFILLp(sv) = -1; + AvMAX(sv) = -1; + AvALLOC(sv) = NULL; + + AvREAL_only(sv); + break; + case SVt_PVHV: + 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; + break; + case SVt_PVOBJ: + ObjectMAXFIELD(sv) = -1; + ObjectFIELDS(sv) = NULL; + break; + default: + NOT_REACHED; + } + + 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 (SVDB_arena(SVt_PVIO)), 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(SVDB_arena(SVt_PVIO)); +#endif + /* FALLTHROUGH */ + case SVt_PVFM: + + assert(SVDB_body_size(SVt_PVIO)); + /* 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(SVDB_arena(SVt_PVIO)) { + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + Zero(new_body, SVDB_body_size(SVt_PVIO), char); + new_body = ((char *)new_body) - SVDB_offset(SVt_PVIO); + } else +#endif + { + new_body = safecalloc(SVDB_body_size(SVt_PVIO) + SVDB_offset(SVt_PVIO), 1); + } + 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); + } + +#undef type + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_typeSVt_PVOBJ(pTHX) +{ + SV *sv; + void* new_body; + + new_SV(sv); + +#define type SVt_PVOBJ + + 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: + case SVt_PVOBJ: + assert(SVDB_body_size(SVt_PVOBJ)); + +#ifndef PURIFY + assert(SVDB_arena(SVt_PVOBJ)); + assert(SVDB_arena_size(SVt_PVOBJ)); + /* 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(!(SVDB_offset(SVt_PVOBJ))); +#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 = safecalloc(SVDB_body_size(SVt_PVOBJ) + SVDB_offset(SVt_PVOBJ), 1); +#endif + SvANY(sv) = new_body; + + SvSTASH_set(sv, NULL); + SvMAGIC_set(sv, NULL); + + switch(type) { + case SVt_PVAV: + AvFILLp(sv) = -1; + AvMAX(sv) = -1; + AvALLOC(sv) = NULL; + + AvREAL_only(sv); + break; + case SVt_PVHV: + 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; + break; + case SVt_PVOBJ: + ObjectMAXFIELD(sv) = -1; + ObjectFIELDS(sv) = NULL; + break; + default: + NOT_REACHED; + } + + 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 (SVDB_arena(SVt_PVOBJ)), 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(SVDB_arena(SVt_PVOBJ)); +#endif + /* FALLTHROUGH */ + case SVt_PVFM: + + assert(SVDB_body_size(SVt_PVOBJ)); + /* 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(SVDB_arena(SVt_PVOBJ)) { + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + Zero(new_body, SVDB_body_size(SVt_PVOBJ), char); + new_body = ((char *)new_body) - SVDB_offset(SVt_PVOBJ); + } else +#endif + { + new_body = safecalloc(SVDB_body_size(SVt_PVOBJ) + SVDB_offset(SVt_PVOBJ), 1); + } + 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); + } + +#undef type + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_NULL(pTHX) +{ + SV *sv = Perl_newSV_typeSVt_NULL(aTHX); + SSize_t ix = ++PL_tmps_ix; + if (UNLIKELY(ix >= PL_tmps_max)) + ix = Perl_tmps_grow_p(aTHX_ ix); + PL_tmps_stack[ix] = (sv); + SvTEMP_on(sv); + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_IV(pTHX) +{ + SV *sv = Perl_newSV_typeSVt_IV(aTHX); + SSize_t ix = ++PL_tmps_ix; + if (UNLIKELY(ix >= PL_tmps_max)) + ix = Perl_tmps_grow_p(aTHX_ ix); + PL_tmps_stack[ix] = (sv); + SvTEMP_on(sv); + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_NV(pTHX) +{ + SV *sv = Perl_newSV_typeSVt_NV(aTHX); + SSize_t ix = ++PL_tmps_ix; + if (UNLIKELY(ix >= PL_tmps_max)) + ix = Perl_tmps_grow_p(aTHX_ ix); + PL_tmps_stack[ix] = (sv); + SvTEMP_on(sv); + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PV(pTHX) +{ + SV *sv = Perl_newSV_typeSVt_PV(aTHX); + SSize_t ix = ++PL_tmps_ix; + if (UNLIKELY(ix >= PL_tmps_max)) + ix = Perl_tmps_grow_p(aTHX_ ix); + PL_tmps_stack[ix] = (sv); + SvTEMP_on(sv); + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_INVLIST(pTHX) +{ + SV *sv = Perl_newSV_typeSVt_INVLIST(aTHX); + SSize_t ix = ++PL_tmps_ix; + if (UNLIKELY(ix >= PL_tmps_max)) + ix = Perl_tmps_grow_p(aTHX_ ix); + PL_tmps_stack[ix] = (sv); + SvTEMP_on(sv); + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVIV(pTHX) +{ + SV *sv = Perl_newSV_typeSVt_PVIV(aTHX); + SSize_t ix = ++PL_tmps_ix; + if (UNLIKELY(ix >= PL_tmps_max)) + ix = Perl_tmps_grow_p(aTHX_ ix); + PL_tmps_stack[ix] = (sv); + SvTEMP_on(sv); + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVNV(pTHX) +{ + SV *sv = Perl_newSV_typeSVt_PVNV(aTHX); + SSize_t ix = ++PL_tmps_ix; + if (UNLIKELY(ix >= PL_tmps_max)) + ix = Perl_tmps_grow_p(aTHX_ ix); + PL_tmps_stack[ix] = (sv); + SvTEMP_on(sv); + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVMG(pTHX) +{ + SV *sv = Perl_newSV_typeSVt_PVMG(aTHX); + SSize_t ix = ++PL_tmps_ix; + if (UNLIKELY(ix >= PL_tmps_max)) + ix = Perl_tmps_grow_p(aTHX_ ix); + PL_tmps_stack[ix] = (sv); + SvTEMP_on(sv); + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_REGEXP(pTHX) +{ + SV *sv = Perl_newSV_typeSVt_REGEXP(aTHX); + SSize_t ix = ++PL_tmps_ix; + if (UNLIKELY(ix >= PL_tmps_max)) + ix = Perl_tmps_grow_p(aTHX_ ix); + PL_tmps_stack[ix] = (sv); + SvTEMP_on(sv); + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVGV(pTHX) +{ + SV *sv = Perl_newSV_typeSVt_PVGV(aTHX); + SSize_t ix = ++PL_tmps_ix; + if (UNLIKELY(ix >= PL_tmps_max)) + ix = Perl_tmps_grow_p(aTHX_ ix); + PL_tmps_stack[ix] = (sv); + SvTEMP_on(sv); + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVLV(pTHX) +{ + SV *sv = Perl_newSV_typeSVt_PVLV(aTHX); + SSize_t ix = ++PL_tmps_ix; + if (UNLIKELY(ix >= PL_tmps_max)) + ix = Perl_tmps_grow_p(aTHX_ ix); + PL_tmps_stack[ix] = (sv); + SvTEMP_on(sv); + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVAV(pTHX) +{ + SV *sv = Perl_newSV_typeSVt_PVAV(aTHX); + SSize_t ix = ++PL_tmps_ix; + if (UNLIKELY(ix >= PL_tmps_max)) + ix = Perl_tmps_grow_p(aTHX_ ix); + PL_tmps_stack[ix] = (sv); + SvTEMP_on(sv); + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVHV(pTHX) +{ + SV *sv = Perl_newSV_typeSVt_PVHV(aTHX); + SSize_t ix = ++PL_tmps_ix; + if (UNLIKELY(ix >= PL_tmps_max)) + ix = Perl_tmps_grow_p(aTHX_ ix); + PL_tmps_stack[ix] = (sv); + SvTEMP_on(sv); + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVCV(pTHX) +{ + SV *sv = Perl_newSV_typeSVt_PVCV(aTHX); + SSize_t ix = ++PL_tmps_ix; + if (UNLIKELY(ix >= PL_tmps_max)) + ix = Perl_tmps_grow_p(aTHX_ ix); + PL_tmps_stack[ix] = (sv); + SvTEMP_on(sv); + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVFM(pTHX) +{ + SV *sv = Perl_newSV_typeSVt_PVFM(aTHX); + SSize_t ix = ++PL_tmps_ix; + if (UNLIKELY(ix >= PL_tmps_max)) + ix = Perl_tmps_grow_p(aTHX_ ix); + PL_tmps_stack[ix] = (sv); + SvTEMP_on(sv); + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVIO(pTHX) +{ + SV *sv = Perl_newSV_typeSVt_PVIO(aTHX); + SSize_t ix = ++PL_tmps_ix; + if (UNLIKELY(ix >= PL_tmps_max)) + ix = Perl_tmps_grow_p(aTHX_ ix); + PL_tmps_stack[ix] = (sv); + SvTEMP_on(sv); + return sv; +} + + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortalSVt_PVOBJ(pTHX) +{ + SV *sv = Perl_newSV_typeSVt_PVOBJ(aTHX); + SSize_t ix = ++PL_tmps_ix; + if (UNLIKELY(ix >= PL_tmps_max)) + ix = Perl_tmps_grow_p(aTHX_ ix); + PL_tmps_stack[ix] = (sv); + SvTEMP_on(sv); + return sv; +} + + + + /* * ex: set ts=8 sts=4 sw=4 et: */ diff --git a/svfix.pl b/svfix.pl new file mode 100644 index 000000000000..42c26f4b09fe --- /dev/null +++ b/svfix.pl @@ -0,0 +1,148 @@ +#!/usr/bin/perl + +use strict; +use Data::Dumper; + my $n; + my $i; +die "usage :" unless @ARGV and $ARGV[0]; +my $fn = $ARGV[0]; +$fn = 'sv_inline.h'; +my $f; +open($f, '<:raw', $fn) || die; +local $/; # enable slurp mode, locally. +my $file = <$f>; +my $mfile = $file; +close($f); + +my $s = index($file, "static const struct body_details bodies_by_type[] = {"); +my $e = index($file, "\n};", $s); +$file = substr($file, $s, ($e+4)-$s); + +my @a; +my @out; +@a = $file =~ / {( .+? )},/gs; +#print Dumper(\@a); +foreach my $l (@a) { + my @c; + my $field = ''; + my $nest = 0; + my $i = 0; + $l =~ s/\/\*[^*]+\*\///gs; + for($i = 0; $i < length $l; $i++) { + my $ch = substr($l, $i, 1); + if($ch eq '(') { + $nest++; + } + elsif($ch eq ')') { + $nest--; + } + elsif($nest == 0 && $ch eq ',') { + $field =~ s/^\s+|\s+$//g; + push(@c, $field); + $field = ''; + next; + } + $field .= $ch; + } + $field =~ s/^\s+|\s+$//g; + push(@c, $field); + push @out, \@c; +} + +my $nv = splice(@out, 2, 1); +for($i=0; $i < @$nv; $i++) { +$out[2][$i] = "("."NVSIZE <= IVSIZE"."?(".@$nv[$i]."):(".$out[2][$i]."))"; +} + + + print Dumper(\@out); +my @names = qw ( + body_size + copy + offset + type + cant_upgrade + zero_nv + arena + arena_size + ); + +my @types = qw( + SVt_NULL + SVt_IV + SVt_NV + SVt_PV + SVt_INVLIST + SVt_PVIV + SVt_PVNV + SVt_PVMG + SVt_REGEXP + SVt_PVGV + SVt_PVLV + SVt_PVAV + SVt_PVHV + SVt_PVCV + SVt_PVFM + SVt_PVIO + SVt_PVOBJ +) +; + +for($i=0; $i < @names; $i++) { + print "#define SVDB_".$names[$i]."(_a) ("; + for($n=0; $n < @out; $n++) { + if($n ==(@out-1)) { + print "(".$out[$n][$i].")"; + } + else { + print "(_a)==".$types[$n]."?(".$out[$n][$i]."):"; + } + } + print ")\n\n"; +} + +$s = index($mfile, "PERL_STATIC_INLINE SV * +Perl_newSV_type(pTHX_ const svtype type)"); +$e = index($mfile, " + return sv; +} +", $s); +my $fn = substr($mfile, $s, $e+18-$s); + +for($n=0; $n < @out; $n++) { + my $tfn = $fn; + my $t = $types[$n]; + $tfn =~ s/\Qtype(pTHX_ const svtype type)\E/type$t(pTHX)/; + $t = "(".$types[$n].")"; + $tfn =~ s/type_details->(\w+)/SVDB_\1$t/gs; + $t = $types[$n]; + $tfn =~ s/\Q type_details = bodies_by_type + type;\E/#define type $t/; + $tfn =~ s/ return sv;/\#undef type\n return sv;/; + $t = "safecalloc(SVDB_body_size(".$types[$n].") + SVDB_offset(".$types[$n]."), 1)"; + $tfn =~ s/new_NOARENAZ\(type_details\)/$t/gs; + $tfn =~ s/\n const struct body_details \*type_details;//; + print $tfn."\n\n"; + if($types[$n] eq "SVt_PV") { + $tfn =~ s/SVt_PV/$tfn/gs + } +} + +$s = index($mfile, 'Perl_newSV_type_mortal(pTHX_ const svtype type)'); +my $mtxt = ' return sv; +} +'; +$e = index($mfile, $mtxt +, $s); + $fn = substr($mfile, $s, $e+length($mtxt)-$s); + +for($n=0; $n < @out; $n++) { + my $tfn = $fn; + my $t = $types[$n]; + $tfn =~ s/\Qmortal(pTHX_ const svtype type)\E/mortal$t(pTHX)/; + $tfn =~ s/\QPerl_newSV_type(pTHX_ type);\E/Perl_newSV_type$t(aTHX);/; + print $tfn."\n\n"; + if($types[$n] eq "SVt_PV") { + $tfn =~ s/SVt_PV/$tfn/gs + } +} + diff --git a/toke.c b/toke.c index 0ff92d2b256f..959f49a6a6b1 100644 --- a/toke.c +++ b/toke.c @@ -12716,7 +12716,7 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) save_item(PL_subname); SAVESPTR(PL_compcv); - PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV)); + PL_compcv = MUTABLE_CV(is_format ? newSV_type(SVt_PVFM) : newSV_type(SVt_PVCV)); CvFLAGS(PL_compcv) |= flags; PL_subline = CopLINE(PL_curcop);