X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a2a5de9516c1b256b060768ac6dad252a3aa3be7..d5cd9e7bba185db6dc6b1e6fa215978a38ae9ea8:/sv.c diff --git a/sv.c b/sv.c index cf1e698..0da4256 100644 --- a/sv.c +++ b/sv.c @@ -353,10 +353,9 @@ S_del_sv(pTHX_ SV *p) } } if (!ok) { - if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "Attempt to free non-arena SV: 0x%"UVxf - pTHX__FORMAT, PTR2UV(p) pTHX__VALUE); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Attempt to free non-arena SV: 0x%"UVxf + pTHX__FORMAT, PTR2UV(p) pTHX__VALUE); return; } } @@ -608,7 +607,7 @@ Perl_sv_clean_all(pTHX) struct arena_desc { char *arena; /* the raw storage, allocated aligned */ size_t size; /* its size ~4k typ */ - U32 misc; /* type, and in future other things. */ + svtype utype; /* bodytype stored in arena */ }; struct arena_set; @@ -690,7 +689,6 @@ Perl_sv_free_arenas(pTHX) 2. regular body arenas 3. arenas for reduced-size bodies 4. Hash-Entry arenas - 5. pte arenas (thread related) Arena types 2 & 3 are chained by body-type off an array of arena-root pointers, which is indexed by svtype. Some of the @@ -709,19 +707,13 @@ Perl_sv_free_arenas(pTHX) HE, HEK arenas are managed separately, with separate code, but may be merge-able later.. - - PTE arenas are not sv-bodies, but they share these mid-level - mechanics, so are considered here. The new mid-level mechanics rely - on the sv_type of the body being allocated, so we just reserve one - of the unused body-slots for PTEs, then use it in those (2) PTE - contexts below (line ~10k) */ /* get_arena(size): this creates custom-sized arenas TBD: export properly for hv.c: S_more_he(). */ void* -Perl_get_arena(pTHX_ const size_t arena_size, const U32 misc) +Perl_get_arena(pTHX_ const size_t arena_size, const svtype bodytype) { dVAR; struct arena_desc* adesc; @@ -750,7 +742,7 @@ Perl_get_arena(pTHX_ const size_t arena_size, const U32 misc) Newx(adesc->arena, arena_size, char); adesc->size = arena_size; - adesc->misc = misc; + adesc->utype = bodytype; DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n", curr, (void*)adesc->arena, (UV)arena_size)); @@ -853,13 +845,6 @@ PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the bodies_by_type[SVt_NULL] slot is not used, as the table is not available in hv.c. -PTEs also use arenas, but are never seen in Perl_sv_upgrade. Nonetheless, -they get their own slot in bodies_by_type[PTE_SVSLOT =SVt_IV], so they can -just use the same allocation semantics. At first, PTEs were also -overloaded to a non-body sv-type, but this yielded hard-to-find malloc -bugs, so was simplified by claiming a new slot. This choice has no -consequence at this time. - */ struct body_details { @@ -922,46 +907,62 @@ static const struct body_details bodies_by_type[] = { implemented. */ { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 }, - /* IVs are in the head, so the allocation size is 0. - However, the slot is overloaded for PTEs. */ - { sizeof(struct ptr_tbl_ent), /* This is used for PTEs. */ + /* IVs are in the head, so the allocation size is 0. */ + { 0, sizeof(IV), /* This is used to copy out the IV body. */ STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV, - NOARENA /* IVS don't need an arena */, - /* But PTEs need to know the size of their arena */ - FIT_ARENA(0, sizeof(struct ptr_tbl_ent)) + NOARENA /* IVS don't need an arena */, 0 }, /* 8 bytes on most ILP32 with IEEE doubles */ - { sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA, - FIT_ARENA(0, sizeof(NV)) }, + { sizeof(NV), sizeof(NV), + STRUCT_OFFSET(XPVNV, xnv_u), + SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) }, /* 8 bytes on most ILP32 with IEEE doubles */ - { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur), + { sizeof(XPV), copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur), + STRUCT_OFFSET(XPV, xpv_cur), SVt_PV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) }, +#if 2 *PTRSIZE <= IVSIZE /* 12 */ - { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur), + { sizeof(XPVIV), copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur), - + STRUCT_OFFSET(XPVIV, xpv_cur), + + STRUCT_OFFSET(XPV, xpv_cur), SVt_PVIV, FALSE, NONV, HASARENA, - FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) }, + FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) }, + /* 12 */ +#else + { sizeof(XPVIV), + copy_length(XPVIV, xiv_u), + 0, + SVt_PVIV, FALSE, NONV, HASARENA, + FIT_ARENA(0, sizeof(XPVIV)) }, +#endif +#if (2 *PTRSIZE <= IVSIZE) && (2 *PTRSIZE <= NVSIZE) /* 20 */ - { sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, SVt_PVNV, FALSE, HADNV, + { sizeof(XPVNV), + copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur), + + STRUCT_OFFSET(XPV, xpv_cur), + SVt_PVNV, FALSE, HADNV, HASARENA, + FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) }, +#else + /* 20 */ + { sizeof(XPVNV), copy_length(XPVNV, xnv_u), 0, SVt_PVNV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVNV)) }, +#endif /* 28 */ - { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV, + { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, /* something big */ - { sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur), - sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur), - + STRUCT_OFFSET(regexp, xpv_cur), + { sizeof(regexp), + sizeof(regexp), + 0, SVt_REGEXP, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur)) }, @@ -974,46 +975,39 @@ static const struct body_details bodies_by_type[] = { { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVLV)) }, - { sizeof(XPVAV) - STRUCT_OFFSET(XPVAV, xav_fill), - copy_length(XPVAV, xmg_stash) - STRUCT_OFFSET(XPVAV, xav_fill), - + STRUCT_OFFSET(XPVAV, xav_fill), + { sizeof(XPVAV), + copy_length(XPVAV, xav_alloc), + 0, SVt_PVAV, TRUE, NONV, HASARENA, - FIT_ARENA(0, sizeof(XPVAV) - STRUCT_OFFSET(XPVAV, xav_fill)) }, + FIT_ARENA(0, sizeof(XPVAV)) }, - { sizeof(XPVHV) - STRUCT_OFFSET(XPVHV, xhv_fill), - copy_length(XPVHV, xmg_stash) - STRUCT_OFFSET(XPVHV, xhv_fill), - + STRUCT_OFFSET(XPVHV, xhv_fill), + { sizeof(XPVHV), + copy_length(XPVHV, xhv_max), + 0, SVt_PVHV, TRUE, NONV, HASARENA, - FIT_ARENA(0, sizeof(XPVHV) - STRUCT_OFFSET(XPVHV, xhv_fill)) }, + FIT_ARENA(0, sizeof(XPVHV)) }, /* 56 */ - { sizeof(XPVCV) - STRUCT_OFFSET(XPVCV, xpv_cur), - sizeof(XPVCV) - STRUCT_OFFSET(XPVCV, xpv_cur), - + STRUCT_OFFSET(XPVCV, xpv_cur), + { sizeof(XPVCV), + sizeof(XPVCV), + 0, SVt_PVCV, TRUE, NONV, HASARENA, - FIT_ARENA(0, sizeof(XPVCV) - STRUCT_OFFSET(XPVCV, xpv_cur)) }, + FIT_ARENA(0, sizeof(XPVCV)) }, - { sizeof(XPVFM) - STRUCT_OFFSET(XPVFM, xpv_cur), - sizeof(XPVFM) - STRUCT_OFFSET(XPVFM, xpv_cur), - + STRUCT_OFFSET(XPVFM, xpv_cur), + { sizeof(XPVFM), + sizeof(XPVFM), + 0, SVt_PVFM, TRUE, NONV, NOARENA, - FIT_ARENA(20, sizeof(XPVFM) - STRUCT_OFFSET(XPVFM, xpv_cur)) }, + FIT_ARENA(20, sizeof(XPVFM)) }, /* XPVIO is 84 bytes, fits 48x */ - { sizeof(XPVIO) - STRUCT_OFFSET(XPVIO, xpv_cur), - sizeof(XPVIO) - STRUCT_OFFSET(XPVIO, xpv_cur), - + STRUCT_OFFSET(XPVIO, xpv_cur), + { sizeof(XPVIO), + sizeof(XPVIO), + 0, SVt_PVIO, TRUE, NONV, HASARENA, - FIT_ARENA(24, sizeof(XPVIO) - STRUCT_OFFSET(XPVIO, xpv_cur)) }, + FIT_ARENA(24, sizeof(XPVIO)) }, }; -#define new_body_type(sv_type) \ - (void *)((char *)S_new_body(aTHX_ sv_type)) - -#define del_body_type(p, sv_type) \ - del_body(p, &PL_body_roots[sv_type]) - - #define new_body_allocated(sv_type) \ (void *)((char *)S_new_body(aTHX_ sv_type) \ - bodies_by_type[sv_type].offset) @@ -1048,11 +1042,11 @@ static const struct body_details bodies_by_type[] = { #else /* !PURIFY */ -#define new_XNV() new_body_type(SVt_NV) -#define del_XNV(p) del_body_type(p, SVt_NV) +#define new_XNV() new_body_allocated(SVt_NV) +#define del_XNV(p) del_body_allocated(p, SVt_NV) -#define new_XPVNV() new_body_type(SVt_PVNV) -#define del_XPVNV(p) del_body_type(p, SVt_PVNV) +#define new_XPVNV() new_body_allocated(SVt_PVNV) +#define del_XPVNV(p) del_body_allocated(p, SVt_PVNV) #define new_XPVAV() new_body_allocated(SVt_PVAV) #define del_XPVAV(p) del_body_allocated(p, SVt_PVAV) @@ -1060,11 +1054,11 @@ static const struct body_details bodies_by_type[] = { #define new_XPVHV() new_body_allocated(SVt_PVHV) #define del_XPVHV(p) del_body_allocated(p, SVt_PVHV) -#define new_XPVMG() new_body_type(SVt_PVMG) -#define del_XPVMG(p) del_body_type(p, SVt_PVMG) +#define new_XPVMG() new_body_allocated(SVt_PVMG) +#define del_XPVMG(p) del_body_allocated(p, SVt_PVMG) -#define new_XPVGV() new_body_type(SVt_PVGV) -#define del_XPVGV(p) del_body_type(p, SVt_PVGV) +#define new_XPVGV() new_body_allocated(SVt_PVGV) +#define del_XPVGV(p) del_body_allocated(p, SVt_PVGV) #endif /* PURIFY */ @@ -1345,13 +1339,6 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) HvSHAREKEYS_on(sv); /* key-sharing on by default */ #endif HvMAX(sv) = 7; /* (start with 8 buckets) */ - if (old_type_details->body_size) { - HvFILL(sv) = 0; - } else { - /* It will have been zeroed when the new body was allocated. - Lets not write to it, in case it confuses a write-back - cache. */ - } } /* SVt_NULL isn't the only thing upgraded to AV or HV. @@ -1373,6 +1360,10 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) break; + case SVt_REGEXP: + /* This ensures that SvTHINKFIRST(sv) is true, and hence that + sv_force_normal_flags(sv) is called. */ + SvFAKE_on(sv); case SVt_PVIV: /* XXX Is this still needed? Was it ever needed? Surely as there is no route from NV to PVIV, NOK can never be true */ @@ -1383,7 +1374,6 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) case SVt_PVGV: case SVt_PVCV: case SVt_PVLV: - case SVt_REGEXP: case SVt_PVMG: case SVt_PVNV: case SVt_PV: @@ -1432,17 +1422,13 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) if (new_type == SVt_PVIO) { IO * const io = MUTABLE_IO(sv); - GV *iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV); + 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 */ hv_clear(PL_stashcache); - /* unless exists($main::{FileHandle}) and - defined(%main::FileHandle::) */ - if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv)))) - iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV); SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); IoPAGE_LEN(sv) = 60; } @@ -1457,14 +1443,14 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) (unsigned long)new_type); } - if (old_type_details->arena) { - /* If there was an old body, then we need to free it. - Note that there is an assumption that all bodies of types that - can be upgraded came from arenas. Only the more complex non- - upgradable types are allowed to be directly malloc()ed. */ + if (old_type > SVt_IV) { #ifdef PURIFY my_safefree(old_body); #else + /* Note that there is an assumption that all bodies of types that + can be upgraded came from arenas. Only the more complex non- + upgradable types are allowed to be directly malloc()ed. */ + assert(old_type_details->arena); del_body((void*)((char*)old_body + old_type_details->offset), &PL_body_roots[old_type]); #endif @@ -1719,7 +1705,7 @@ Perl_sv_setnv(pTHX_ register SV *const sv, const NV num) case SVt_PVFM: case SVt_PVIO: Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), - OP_NAME(PL_op)); + OP_DESC(PL_op)); default: NOOP; } SvNV_set(sv, num); @@ -2341,7 +2327,10 @@ Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags) if (SvROK(sv)) { return_rok: if (SvAMAGIC(sv)) { - SV * const tmpstr=AMG_CALLun(sv,numer); + SV * tmpstr; + if (flags & SV_SKIP_OVERLOAD) + return 0; + tmpstr=AMG_CALLun(sv,numer); if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { return SvIV(tmpstr); } @@ -2417,7 +2406,10 @@ Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags) if (SvROK(sv)) { return_rok: if (SvAMAGIC(sv)) { - SV *const tmpstr = AMG_CALLun(sv,numer); + SV *tmpstr; + if (flags & SV_SKIP_OVERLOAD) + return 0; + tmpstr = AMG_CALLun(sv,numer); if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { return SvUV(tmpstr); } @@ -2444,17 +2436,17 @@ Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags) } /* -=for apidoc sv_2nv +=for apidoc sv_2nv_flags Return the num value of an SV, doing any necessary string or integer -conversion, magic etc. Normally used via the C and C -macros. +conversion. If flags includes SV_GMAGIC, does an mg_get() first. +Normally used via the C and C macros. =cut */ NV -Perl_sv_2nv(pTHX_ register SV *const sv) +Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags) { dVAR; if (!sv) @@ -2462,7 +2454,8 @@ Perl_sv_2nv(pTHX_ register SV *const sv) if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) { /* FBMs use the same flag bit as SVf_IVisUV, so must let them cache IVs just in case. */ - mg_get(sv); + if (flags & SV_GMAGIC) + mg_get(sv); if (SvNOKp(sv)) return SvNVX(sv); if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) { @@ -2487,7 +2480,10 @@ Perl_sv_2nv(pTHX_ register SV *const sv) if (SvROK(sv)) { return_rok: if (SvAMAGIC(sv)) { - SV *const tmpstr = AMG_CALLun(sv,numer); + SV *tmpstr; + if (flags & SV_SKIP_OVERLOAD) + return 0; + tmpstr = AMG_CALLun(sv,numer); if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { return SvNV(tmpstr); } @@ -2804,7 +2800,10 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags if (SvROK(sv)) { return_rok: if (SvAMAGIC(sv)) { - SV *const tmpstr = AMG_CALLun(sv,string); + SV *tmpstr; + if (flags & SV_SKIP_OVERLOAD) + return NULL; + tmpstr = AMG_CALLun(sv,string); if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { /* Unwrap this: */ /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); @@ -2991,11 +2990,17 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags gv_efullname3(buffer, gv, "*"); SvFLAGS(gv) |= wasfake; - assert(SvPOK(buffer)); - if (lp) { - *lp = SvCUR(buffer); + if (SvPOK(buffer)) { + if (lp) { + *lp = SvCUR(buffer); + } + return SvPVX(buffer); + } + else { + if (lp) + *lp = 0; + return (char *)""; } - return SvPVX(buffer); } if (lp) @@ -3120,7 +3125,7 @@ Perl_sv_2bool(pTHX_ register SV *const sv) if (SvAMAGIC(sv)) { SV * const tmpsv = AMG_CALLun(sv,bool_); if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) - return (bool)SvTRUE(tmpsv); + return cBOOL(SvTRUE(tmpsv)); } return SvRV(sv) != 0; } @@ -3251,7 +3256,9 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, ST return SvCUR(sv); } - if (SvCUR(sv) > 0) { /* Assume Latin-1/EBCDIC */ + if (SvCUR(sv) == 0) { + if (extra) SvGROW(sv, extra); + } else { /* Assume Latin-1/EBCDIC */ /* This function could be much more efficient if we * had a FLAG in SVs to signal if there are any variant * chars in the PV. Given that there isn't such a flag @@ -3679,7 +3686,6 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) SV **location; U8 import_flag = 0; const U32 stype = SvTYPE(sref); - bool mro_changes = FALSE; PERL_ARGS_ASSERT_GLOB_ASSIGN_REF; @@ -3700,8 +3706,6 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) goto common; case SVt_PVAV: location = (SV **) &GvAV(dstr); - if (strEQ(GvNAME((GV*)dstr), "ISA")) - mro_changes = TRUE; import_flag = GVf_IMPORTED_AV; goto common; case SVt_PVIO: @@ -3775,12 +3779,15 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { GvFLAGS(dstr) |= import_flag; } + if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) { + sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0); + mro_isa_changed_in(GvSTASH(dstr)); + } break; } SvREFCNT_dec(dref); if (SvTAINTED(sstr)) SvTAINT(dstr); - if (mro_changes) mro_isa_changed_in(GvSTASH(dstr)); return; } @@ -3892,7 +3899,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } /* Fall through */ #endif - case SVt_REGEXP: case SVt_PV: if (dtype < SVt_PV) sv_upgrade(dstr, SVt_PV); @@ -3909,12 +3915,17 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) { const char * const type = sv_reftype(sstr,0); if (PL_op) - Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op)); + Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op)); else Perl_croak(aTHX_ "Bizarre copy of %s", type); } break; + case SVt_REGEXP: + if (dtype < SVt_REGEXP) + sv_upgrade(dstr, SVt_REGEXP); + break; + /* case SVt_BIND: */ case SVt_PVLV: case SVt_PVGV: @@ -3964,7 +3975,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) { const char * const type = sv_reftype(dstr,0); if (PL_op) - Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_NAME(PL_op)); + Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op)); else Perl_croak(aTHX_ "Cannot copy to %s", type); } else if (sflags & SVf_ROK) { @@ -4017,6 +4028,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } } } + else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) { + reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr); + } else if (sflags & SVp_POK) { bool isSwipe = 0; @@ -4067,9 +4081,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) (!(flags & SV_NOSTEAL)) && /* and we're allowed to steal temps */ SvREFCNT(sstr) == 1 && /* and no other references to it? */ - SvLEN(sstr) && /* and really is a string */ - /* and won't be needed again, potentially */ - !(PL_op && PL_op->op_type == OP_AASSIGN)) + SvLEN(sstr)) /* and really is a string */ #ifdef PERL_OLD_COPY_ON_WRITE && ((flags & SV_COW_SHARED_HASH_KEYS) ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS @@ -4605,6 +4617,45 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags) sv_unref_flags(sv, flags); else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) sv_unglob(sv); + else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) { + /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous + to sv_unglob. We only need it here, so inline it. */ + const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV; + SV *const temp = newSV_type(new_type); + void *const temp_p = SvANY(sv); + + if (new_type == SVt_PVMG) { + SvMAGIC_set(temp, SvMAGIC(sv)); + SvMAGIC_set(sv, NULL); + SvSTASH_set(temp, SvSTASH(sv)); + SvSTASH_set(sv, NULL); + } + SvCUR_set(temp, SvCUR(sv)); + /* Remember that SvPVX is in the head, not the body. */ + if (SvLEN(temp)) { + SvLEN_set(temp, SvLEN(sv)); + /* This signals "buffer is owned by someone else" in sv_clear, + which is the least effort way to stop it freeing the buffer. + */ + SvLEN_set(sv, SvLEN(sv)+1); + } else { + /* Their buffer is already owned by someone else. */ + SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv)); + SvLEN_set(temp, SvCUR(sv)+1); + } + + /* Now swap the rest of the bodies. */ + + SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK); + SvFLAGS(sv) |= new_type; + SvANY(sv) = SvANY(temp); + + SvFLAGS(temp) &= ~(SVTYPEMASK); + SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE; + SvANY(temp) = temp_p; + + SvREFCNT_dec(temp); + } } /* @@ -5205,12 +5256,14 @@ Perl_sv_unmagic(pTHX_ SV *const sv, const int type) else mgp = &mg->mg_moremagic; } - if (!SvMAGIC(sv)) { + if (SvMAGIC(sv)) { + if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */ + mg_magical(sv); /* else fix the flags now */ + } + else { SvMAGICAL_off(sv); SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; - SvMAGIC_set(sv, NULL); } - return 0; } @@ -5622,15 +5675,9 @@ Perl_sv_clear(pTHX_ register SV *const sv) if (type <= SVt_IV) { /* See the comment in sv.h about the collusion between this early - return and the overloading of the NULL and IV slots in the size - table. */ - if (SvROK(sv)) { - SV * const target = SvRV(sv); - if (SvWEAKREF(sv)) - sv_del_backref(target, sv); - else - SvREFCNT_dec(target); - } + return and the overloading of the NULL slots in the size table. */ + if (SvROK(sv)) + goto free_rv; SvFLAGS(sv) &= SVf_BREAK; SvFLAGS(sv) |= SVTYPEMASK; return; @@ -5652,7 +5699,8 @@ Perl_sv_clear(pTHX_ register SV *const sv) && !CvCONST(destructor) /* Don't bother calling an empty destructor */ && (CvISXSUB(destructor) - || CvSTART(destructor)->op_next->op_type != OP_LEAVESUB)) + || (CvSTART(destructor) + && (CvSTART(destructor)->op_next->op_type != OP_LEAVESUB)))) { SV* const tmpref = newRV(sv); SvREADONLY_on(tmpref); /* DESTROY() could be naughty */ @@ -5781,11 +5829,14 @@ Perl_sv_clear(pTHX_ register SV *const sv) /* Don't even bother with turning off the OOK flag. */ } if (SvROK(sv)) { - SV * const target = SvRV(sv); - if (SvWEAKREF(sv)) - sv_del_backref(target, sv); - else - SvREFCNT_dec(target); + free_rv: + { + SV * const target = SvRV(sv); + if (SvWEAKREF(sv)) + sv_del_backref(target, sv); + else + SvREFCNT_dec(target); + } } #ifdef PERL_OLD_COPY_ON_WRITE else if (SvPVX_const(sv)) { @@ -5916,10 +5967,9 @@ Perl_sv_free2(pTHX_ SV *const sv) #ifdef DEBUGGING if (SvTEMP(sv)) { - if (ckWARN_d(WARN_DEBUGGING)) - Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), - "Attempt to free temp prematurely: SV 0x%"UVxf - pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), + "Attempt to free temp prematurely: SV 0x%"UVxf + pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); return; } #endif @@ -6011,12 +6061,17 @@ Perl_sv_len_utf8(pTHX_ register SV *const sv) else { ulen = Perl_utf8_length(aTHX_ s, s + len); if (!SvREADONLY(sv)) { - if (!mg) { + if (!mg && (SvTYPE(sv) < SVt_PVMG || + !(mg = mg_find(sv, PERL_MAGIC_utf8)))) { mg = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0); } assert(mg); mg->mg_len = ulen; + /* For now, treat "overflowed" as "still unknown". + See RT #72924. */ + if (ulen != (STRLEN) mg->mg_len) + mg->mg_len = -1; } } return ulen; @@ -6091,8 +6146,10 @@ S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start assert (uoffset >= uoffset0); - if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache - && (*mgp || (*mgp = mg_find(sv, PERL_MAGIC_utf8)))) { + if (!SvREADONLY(sv) + && PL_utf8cache + && (*mgp || (SvTYPE(sv) >= SVt_PVMG && + (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) { if ((*mgp)->mg_ptr) { STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr; if (cache[0] == uoffset) { @@ -6183,62 +6240,97 @@ S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start /* -=for apidoc sv_pos_u2b +=for apidoc sv_pos_u2b_flags Converts the value pointed to by offsetp from a count of UTF-8 chars from the start of the string, to a count of the equivalent number of bytes; if lenp is non-zero, it does the same to lenp, but this time starting from -the offset, rather than from the start of the string. Handles magic and -type coercion. +the offset, rather than from the start of the string. Handles type coercion. +I is passed to C, and usually should be +C to handle magic. =cut */ /* - * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential + * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and * byte offsets. See also the comments of S_utf8_mg_pos_cache_update(). * */ -void -Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp) +STRLEN +Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp, + U32 flags) { const U8 *start; STRLEN len; + STRLEN boffset; - PERL_ARGS_ASSERT_SV_POS_U2B; - - if (!sv) - return; + PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS; - start = (U8*)SvPV_const(sv, len); + start = (U8*)SvPV_flags(sv, len, flags); if (len) { - STRLEN uoffset = (STRLEN) *offsetp; const U8 * const send = start + len; MAGIC *mg = NULL; - const STRLEN boffset = sv_pos_u2b_cached(sv, &mg, start, send, - uoffset, 0, 0); - - *offsetp = (I32) boffset; + boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0); if (lenp) { /* Convert the relative offset to absolute. */ - const STRLEN uoffset2 = uoffset + (STRLEN) *lenp; + const STRLEN uoffset2 = uoffset + *lenp; const STRLEN boffset2 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2, uoffset, boffset) - boffset; *lenp = boffset2; } - } - else { - *offsetp = 0; - if (lenp) - *lenp = 0; + } else { + if (lenp) + *lenp = 0; + boffset = 0; } - return; + return boffset; +} + +/* +=for apidoc sv_pos_u2b + +Converts the value pointed to by offsetp from a count of UTF-8 chars from +the start of the string, to a count of the equivalent number of bytes; if +lenp is non-zero, it does the same to lenp, but this time starting from +the offset, rather than from the start of the string. Handles magic and +type coercion. + +Use C in preference, which correctly handles strings longer +than 2Gb. + +=cut +*/ + +/* + * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential + * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and + * byte offsets. See also the comments of S_utf8_mg_pos_cache_update(). + * + */ + +/* This function is subject to size and sign problems */ + +void +Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp) +{ + PERL_ARGS_ASSERT_SV_POS_U2B; + + if (lenp) { + STRLEN ulen = (STRLEN)*lenp; + *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen, + SV_GMAGIC|SV_CONST_RETURN); + *lenp = (I32)ulen; + } else { + *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL, + SV_GMAGIC|SV_CONST_RETURN); + } } /* Create and update the UTF8 magic offset cache, with the proffered utf8/ @@ -6275,7 +6367,8 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN b if (SvREADONLY(sv)) return; - if (!*mgp) { + if (!*mgp && (SvTYPE(sv) < SVt_PVMG || + !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) { *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0); (*mgp)->mg_len = -1; @@ -6472,8 +6565,11 @@ Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp) send = s + byte; - if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache - && (mg = mg_find(sv, PERL_MAGIC_utf8))) { + if (!SvREADONLY(sv) + && PL_utf8cache + && SvTYPE(sv) >= SVt_PVMG + && (mg = mg_find(sv, PERL_MAGIC_utf8))) + { if (mg->mg_ptr) { STRLEN * const cache = (STRLEN *) mg->mg_ptr; if (cache[1] == byte) { @@ -7220,7 +7316,7 @@ return_string_or_null: =for apidoc sv_inc Auto-increment of the value in the SV, doing string to numeric conversion -if necessary. Handles 'get' magic. +if necessary. Handles 'get' magic and operator overloading. =cut */ @@ -7228,13 +7324,30 @@ if necessary. Handles 'get' magic. void Perl_sv_inc(pTHX_ register SV *const sv) { + if (!sv) + return; + SvGETMAGIC(sv); + sv_inc_nomg(sv); +} + +/* +=for apidoc sv_inc_nomg + +Auto-increment of the value in the SV, doing string to numeric conversion +if necessary. Handles operator overloading. Skips handling 'get' magic. + +=cut +*/ + +void +Perl_sv_inc_nomg(pTHX_ register SV *const sv) +{ dVAR; register char *d; int flags; if (!sv) return; - SvGETMAGIC(sv); if (SvTHINKFIRST(sv)) { if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); @@ -7384,7 +7497,7 @@ Perl_sv_inc(pTHX_ register SV *const sv) =for apidoc sv_dec Auto-decrement of the value in the SV, doing string to numeric conversion -if necessary. Handles 'get' magic. +if necessary. Handles 'get' magic and operator overloading. =cut */ @@ -7393,11 +7506,29 @@ void Perl_sv_dec(pTHX_ register SV *const sv) { dVAR; + if (!sv) + return; + SvGETMAGIC(sv); + sv_dec_nomg(sv); +} + +/* +=for apidoc sv_dec_nomg + +Auto-decrement of the value in the SV, doing string to numeric conversion +if necessary. Handles operator overloading. Skips handling 'get' magic. + +=cut +*/ + +void +Perl_sv_dec_nomg(pTHX_ register SV *const sv) +{ + dVAR; int flags; if (!sv) return; - SvGETMAGIC(sv); if (SvTHINKFIRST(sv)) { if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); @@ -7574,7 +7705,8 @@ string. You are responsible for ensuring that the source string is at least C bytes long. If the C argument is NULL the new SV will be undefined. Currently the only flag bits accepted are C and C. If C is set, then C is called on the result before -returning. If C is set, then it will be set on the new SV. +returning. If C is set, C is considered to be in UTF-8 and the +C flag will be set on the new SV. C is a convenience wrapper for this function, defined as #define newSVpvn_utf8(s, len, u) \ @@ -7996,8 +8128,7 @@ Perl_newSVsv(pTHX_ register SV *const old) if (!old) return NULL; if (SvTYPE(old) == SVTYPEMASK) { - if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string"); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string"); return NULL; } new_SV(sv); @@ -8335,14 +8466,14 @@ Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) const char * const ref = sv_reftype(sv,0); if (PL_op) Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s", - ref, OP_NAME(PL_op)); + ref, OP_DESC(PL_op)); else Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref); } if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) || isGV_with_GP(sv)) Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), - OP_NAME(PL_op)); + OP_DESC(PL_op)); s = sv_2pv_flags(sv, &len, flags); if (lp) *lp = len; @@ -9159,6 +9290,22 @@ Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted); } + +/* + * Warn of missing argument to sprintf, and then return a defined value + * to avoid inappropriate "use of uninit" warnings [perl #71000]. + */ +#define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */ +STATIC SV* +S_vcatpvfn_missing_argument(pTHX) { + if (ckWARN(WARN_MISSING)) { + Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s", + PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); + } + return &PL_sv_no; +} + + STATIC I32 S_expect_number(pTHX_ char **const pattern) { @@ -9175,7 +9322,7 @@ S_expect_number(pTHX_ char **const pattern) while (isDIGIT(**pattern)) { const I32 tmp = var * 10 + (*(*pattern)++ - '0'); if (tmp < var) - Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn")); + Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn")); var = tmp; } } @@ -9271,6 +9418,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, else if (svix < svmax) { sv_catsv(sv, *svargs); } + else + S_vcatpvfn_missing_argument(aTHX); return; } if (args && patlen == 3 && pat[0] == '%' && @@ -9290,13 +9439,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, pp = pat + 2; while (*pp >= '0' && *pp <= '9') digits = 10 * digits + (*pp++ - '0'); - if (pp - pat == (int)patlen - 1) { - NV nv; - - if (svix < svmax) - nv = SvNV(*svargs); - else - return; + if (pp - pat == (int)patlen - 1 && svix < svmax) { + const NV nv = SvNV(*svargs); if (*pp == 'g') { /* Add check for digits != 0 because it seems that some gconverts are buggy in this case, and we don't yet have @@ -9442,9 +9586,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, goto string; } else if (n) { - if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "internal %%p might conflict with future printf extensions"); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "internal %%p might conflict with future printf extensions"); } } q = r; @@ -9525,9 +9668,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, vecsv = va_arg(*args, SV*); else if (evix) { vecsv = (evix > 0 && evix <= svmax) - ? svargs[evix-1] : &PL_sv_undef; + ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX); } else { - vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef; + vecsv = svix < svmax + ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX); } dotstr = SvPV_const(vecsv, dotstrlen); /* Keep the DO_UTF8 test *after* the SvPV call, else things go @@ -9674,10 +9818,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, if (!vectorize && !args) { if (efix) { const I32 i = efix-1; - argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef; + argsv = (i >= 0 && i < svmax) + ? svargs[i] : S_vcatpvfn_missing_argument(aTHX); } else { argsv = (svix >= 0 && svix < svmax) - ? svargs[svix++] : &PL_sv_undef; + ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX); } } @@ -10314,6 +10459,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, goto vector; } } + SvTAINT(sv); } /* ========================================================================= @@ -10345,18 +10491,17 @@ ptr_table_* functions. that currently av_dup, gv_dup and hv_dup are the same as sv_dup. If this changes, please unmerge ss_dup. Likewise, sv_dup_inc_multiple() relies on this fact. */ -#define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t)) -#define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t)) +#define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup_inc(s,t)) #define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t)) -#define av_dup_inc(s,t) MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)s,t))) +#define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t)) #define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t)) -#define hv_dup_inc(s,t) MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)s,t))) +#define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t)) #define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t)) -#define cv_dup_inc(s,t) MUTABLE_CV(SvREFCNT_inc(sv_dup((const SV *)s,t))) +#define cv_dup_inc(s,t) MUTABLE_CV(sv_dup_inc((const SV *)s,t)) #define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t)) -#define io_dup_inc(s,t) MUTABLE_IO(SvREFCNT_inc(sv_dup((const SV *)s,t))) +#define io_dup_inc(s,t) MUTABLE_IO(sv_dup_inc((const SV *)s,t)) #define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t)) -#define gv_dup_inc(s,t) MUTABLE_GV(SvREFCNT_inc(sv_dup((const SV *)s,t))) +#define gv_dup_inc(s,t) MUTABLE_GV(sv_dup_inc((const SV *)s,t)) #define SAVEPV(p) ((p) ? savepv(p) : NULL) #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL) @@ -10619,6 +10764,11 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param) #endif /* USE_ITHREADS */ +struct ptr_tbl_arena { + struct ptr_tbl_arena *next; + struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers. */ +}; + /* create a new pointer-mapping table */ PTR_TBL_t * @@ -10630,6 +10780,9 @@ Perl_ptr_table_new(pTHX) Newx(tbl, 1, PTR_TBL_t); tbl->tbl_max = 511; tbl->tbl_items = 0; + tbl->tbl_arena = NULL; + tbl->tbl_arena_next = NULL; + tbl->tbl_arena_end = NULL; Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*); return tbl; } @@ -10637,14 +10790,6 @@ Perl_ptr_table_new(pTHX) #define PTR_TABLE_HASH(ptr) \ ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17))) -/* - we use the PTE_SVSLOT 'reservation' made above, both here (in the - following define) and at call to new_body_inline made below in - Perl_ptr_table_store() - */ - -#define del_pte(p) del_body_type(p, PTE_SVSLOT) - /* map an existing pointer using a table */ STATIC PTR_TBL_ENT_t * @@ -10689,7 +10834,18 @@ Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void * } else { const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max; - new_body_inline(tblent, PTE_SVSLOT); + if (tbl->tbl_arena_next == tbl->tbl_arena_end) { + struct ptr_tbl_arena *new_arena; + + Newx(new_arena, 1, struct ptr_tbl_arena); + new_arena->next = tbl->tbl_arena; + tbl->tbl_arena = new_arena; + tbl->tbl_arena_next = new_arena->array; + tbl->tbl_arena_end = new_arena->array + + sizeof(new_arena->array) / sizeof(new_arena->array[0]); + } + + tblent = tbl->tbl_arena_next++; tblent->oldval = oldsv; tblent->newval = newsv; @@ -10737,25 +10893,27 @@ Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl) } /* remove all the entries from a ptr table */ +/* Deprecated - will be removed post 5.14 */ void Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl) { if (tbl && tbl->tbl_items) { - register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary; - UV riter = tbl->tbl_max; + struct ptr_tbl_arena *arena = tbl->tbl_arena; - do { - PTR_TBL_ENT_t *entry = array[riter]; + Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **); - while (entry) { - PTR_TBL_ENT_t * const oentry = entry; - entry = entry->next; - del_pte(oentry); - } - } while (riter--); + while (arena) { + struct ptr_tbl_arena *next = arena->next; + + Safefree(arena); + arena = next; + }; tbl->tbl_items = 0; + tbl->tbl_arena = NULL; + tbl->tbl_arena_next = NULL; + tbl->tbl_arena_end = NULL; } } @@ -10764,10 +10922,21 @@ Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl) void Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl) { + struct ptr_tbl_arena *arena; + if (!tbl) { return; } - ptr_table_clear(tbl); + + arena = tbl->tbl_arena; + + while (arena) { + struct ptr_tbl_arena *next = arena->next; + + Safefree(arena); + arena = next; + } + Safefree(tbl->tbl_ary); Safefree(tbl); } @@ -10836,16 +11005,14 @@ S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest, /* duplicate an SV of any type (including AV, HV etc) */ -SV * -Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) +static SV * +S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) { dVAR; SV *dstr; - PERL_ARGS_ASSERT_SV_DUP; + PERL_ARGS_ASSERT_SV_DUP_COMMON; - if (!sstr) - return NULL; if (SvTYPE(sstr) == SVTYPEMASK) { #ifdef DEBUG_LEAKING_SCALARS_ABORT abort(); @@ -11007,10 +11174,23 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param); /* Don't call sv_add_backref here as it's going to be created as part of the magic cloning of the symbol - table. */ + table--unless this is during a join and the stash + is not actually being cloned. */ /* Danger Will Robinson - GvGP(dstr) isn't initialised at the point of this comment. */ GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param); + if(param->flags & CLONEf_JOIN_IN) { + const HEK * const hvname + = HvNAME_HEK(GvSTASH(dstr)); + if( hvname + && GvSTASH(dstr) == gv_stashpvn( + HEK_KEY(hvname), HEK_LEN(hvname), 0 + ) + ) + Perl_sv_add_backref( + aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr + ); + } GvGP(dstr) = gp_dup(GvGP(sstr), param); (void)GpREFCNT_inc(GvGP(dstr)); } else @@ -11107,7 +11287,7 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) daux->xhv_riter = saux->xhv_riter; daux->xhv_eiter = saux->xhv_eiter ? he_dup(saux->xhv_eiter, - (bool)!!HvSHAREKEYS(sstr), param) : 0; + cBOOL(HvSHAREKEYS(sstr)), param) : 0; /* backref array needs refcnt=2; see sv_add_backref */ daux->xhv_backreferences = saux->xhv_backreferences @@ -11146,7 +11326,7 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) * duped GV may never be freed. A bit of a hack! DAPM */ CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ? NULL : gv_dup(CvGV(dstr), param) ; - PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param); + CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param); CvOUTSIDE(dstr) = CvWEAKOUTSIDE(sstr) ? cv_dup( CvOUTSIDE(dstr), param) @@ -11164,6 +11344,28 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) return dstr; } +SV * +Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) +{ + PERL_ARGS_ASSERT_SV_DUP_INC; + return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL; +} + +SV * +Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) +{ + SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL; + PERL_ARGS_ASSERT_SV_DUP; + + /* Track every SV that (at least initially) had a reference count of 0. */ + if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) { + assert(param->unreferenced); + av_push(param->unreferenced, dstr); + } + + return dstr; +} + /* duplicate a context */ PERL_CONTEXT * @@ -11290,6 +11492,8 @@ Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param) #define TOPLONG(ss,ix) ((ss)[ix].any_long) #define POPIV(ss,ix) ((ss)[--(ix)].any_iv) #define TOPIV(ss,ix) ((ss)[ix].any_iv) +#define POPUV(ss,ix) ((ss)[--(ix)].any_uv) +#define TOPUV(ss,ix) ((ss)[ix].any_uv) #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool) #define TOPBOOL(ss,ix) ((ss)[ix].any_bool) #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr) @@ -11362,9 +11566,13 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) Newxz(nss, max, ANY); while (ix > 0) { - const I32 type = POPINT(ss,ix); - TOPINT(nss,ix) = type; + const UV uv = POPUV(ss,ix); + const U8 type = (U8)uv & SAVE_MASK; + + TOPUV(nss,ix) = uv; switch (type) { + case SAVEt_CLEARSV: + break; case SAVEt_HELEM: /* hash element */ sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); @@ -11411,14 +11619,10 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) case SAVEt_LONG: /* long reference */ ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - /* fall through */ - case SAVEt_CLEARSV: longval = (long)POPLONG(ss,ix); TOPLONG(nss,ix) = longval; break; case SAVEt_I32: /* I32 reference */ - case SAVEt_I16: /* I16 reference */ - case SAVEt_I8: /* I8 reference */ case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */ ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); @@ -11442,6 +11646,12 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) case SAVEt_VPTR: /* random* reference */ ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + /* Fall through */ + case SAVEt_INT_SMALL: + case SAVEt_I32_SMALL: + case SAVEt_I16: /* I16 reference */ + case SAVEt_I8: /* I8 reference */ + case SAVEt_BOOL: ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); break; @@ -11453,12 +11663,14 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) TOPPTR(nss,ix) = pv_dup(c); break; case SAVEt_GP: /* scalar reference */ + gv = (const GV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup_inc(gv, param); gp = (GP*)POPPTR(ss,ix); TOPPTR(nss,ix) = gp = gp_dup(gp, param); (void)GpREFCNT_inc(gp); - gv = (const GV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = gv_dup_inc(gv, param); - break; + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; case SAVEt_FREEOP: ptr = POPPTR(ss,ix); if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) { @@ -11517,9 +11729,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) break; case SAVEt_REGCONTEXT: case SAVEt_ALLOC: - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - ix -= i; + ix -= uv >> SAVE_TIGHT_SHIFT; break; case SAVEt_AELEM: /* array element */ sv = (const SV *)POPPTR(ss,ix); @@ -11556,12 +11766,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); break; - case SAVEt_BOOL: - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - longval = (long)POPBOOL(ss,ix); - TOPBOOL(nss,ix) = (bool)longval; - break; case SAVEt_SET_SVFLAGS: i = POPINT(ss,ix); TOPINT(nss,ix) = i; @@ -11769,27 +11973,40 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); PERL_ARGS_ASSERT_PERL_CLONE_USING; +#else /* !PERL_IMPLICIT_SYS */ + IV i; + CLONE_PARAMS clone_params; + CLONE_PARAMS* param = &clone_params; + PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); + + PERL_ARGS_ASSERT_PERL_CLONE; +#endif /* PERL_IMPLICIT_SYS */ /* for each stash, determine whether its objects should be cloned */ S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); PERL_SET_THX(my_perl); -# ifdef DEBUGGING +#ifdef DEBUGGING PoisonNew(my_perl, 1, PerlInterpreter); PL_op = NULL; PL_curcop = NULL; PL_markstack = 0; PL_scopestack = 0; + PL_scopestack_name = 0; PL_savestack = 0; PL_savestack_ix = 0; PL_savestack_max = -1; PL_sig_pending = 0; PL_parser = NULL; Zero(&PL_debug_pad, 1, struct perl_debug_pad); -# else /* !DEBUGGING */ +# ifdef DEBUG_LEAKING_SCALARS + PL_sv_serial = (((U32)my_perl >> 2) & 0xfff) * 1000000; +# endif +#else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); -# endif /* DEBUGGING */ +#endif /* DEBUGGING */ +#ifdef PERL_IMPLICIT_SYS /* host pointers */ PL_Mem = ipM; PL_MemShared = ipMS; @@ -11800,36 +12017,16 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_Dir = ipD; PL_Sock = ipS; PL_Proc = ipP; -#else /* !PERL_IMPLICIT_SYS */ - IV i; - CLONE_PARAMS clone_params; - CLONE_PARAMS* param = &clone_params; - PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); - - PERL_ARGS_ASSERT_PERL_CLONE; - - /* for each stash, determine whether its objects should be cloned */ - S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); - PERL_SET_THX(my_perl); - -# ifdef DEBUGGING - PoisonNew(my_perl, 1, PerlInterpreter); - PL_op = NULL; - PL_curcop = NULL; - PL_markstack = 0; - PL_scopestack = 0; - PL_savestack = 0; - PL_savestack_ix = 0; - PL_savestack_max = -1; - PL_sig_pending = 0; - PL_parser = NULL; - Zero(&PL_debug_pad, 1, struct perl_debug_pad); -# else /* !DEBUGGING */ - Zero(my_perl, 1, PerlInterpreter); -# endif /* DEBUGGING */ #endif /* PERL_IMPLICIT_SYS */ + param->flags = flags; + /* Nothing in the core code uses this, but we make it available to + extensions (using mg_dup). */ param->proto_perl = proto_perl; + /* Likely nothing will use this, but it is initialised to be consistent + with Perl_clone_params_new(). */ + param->proto_perl = my_perl; + param->unreferenced = NULL; INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl); @@ -11887,6 +12084,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, SvNV_set(&PL_sv_yes, 1); ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes); + /* dbargs array probably holds garbage */ + PL_dbargs = NULL; + /* create (a non-shared!) shared string table */ PL_strtab = newHV(); HvSHAREKEYS_off(PL_strtab); @@ -11920,6 +12120,18 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_origargv = proto_perl->Iorigargv; param->stashes = newAV(); /* Setup array of objects to call clone on */ + /* This makes no difference to the implementation, as it always pushes + and shifts pointers to other SVs without changing their reference + count, with the array becoming empty before it is freed. However, it + makes it conceptually clear what is going on, and will avoid some + work inside av.c, filling slots between AvFILL() and AvMAX() with + &PL_sv_undef, and SvREFCNT_dec()ing those. */ + AvREAL_off(param->stashes); + + if (!(flags & CLONEf_COPY_STACKS)) { + param->unreferenced = newAV(); + AvREAL_off(param->unreferenced); + } /* Set tainting stuff before PerlIO_debug can possibly get called */ PL_tainting = proto_perl->Itainting; @@ -12013,7 +12225,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_DBsingle = sv_dup(proto_perl->IDBsingle, param); PL_DBtrace = sv_dup(proto_perl->IDBtrace, param); PL_DBsignal = sv_dup(proto_perl->IDBsignal, param); - PL_dbargs = av_dup(proto_perl->Idbargs, param); /* symbol tables */ PL_defstash = hv_dup_inc(proto_perl->Idefstash, param); @@ -12184,6 +12395,16 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param); PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param); PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param); + PL_utf8_X_begin = sv_dup_inc(proto_perl->Iutf8_X_begin, param); + PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param); + PL_utf8_X_prepend = sv_dup_inc(proto_perl->Iutf8_X_prepend, param); + PL_utf8_X_non_hangul = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param); + PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param); + PL_utf8_X_LV = sv_dup_inc(proto_perl->Iutf8_X_LV, param); + PL_utf8_X_LVT = sv_dup_inc(proto_perl->Iutf8_X_LVT, param); + PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param); + PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param); + PL_utf8_X_LV_LVT_V = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param); PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param); PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param); PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param); @@ -12259,8 +12480,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_tmps_max = proto_perl->Itmps_max; PL_tmps_floor = proto_perl->Itmps_floor; Newx(PL_tmps_stack, PL_tmps_max, SV*); - sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack, PL_tmps_ix, - param); + sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack, + PL_tmps_ix+1, param); /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ i = proto_perl->Imarkstack_max - proto_perl->Imarkstack; @@ -12279,6 +12500,10 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, Newxz(PL_scopestack, PL_scopestack_max, I32); Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32); +#ifdef DEBUGGING + Newxz(PL_scopestack_name, PL_scopestack_max, const char *); + Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *); +#endif /* NOTE: si_dup() looks at PL_markstack */ PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param); @@ -12302,19 +12527,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, else { init_stacks(); ENTER; /* perl_destruct() wants to LEAVE; */ - - /* although we're not duplicating the tmps stack, we should still - * add entries for any SVs on the tmps stack that got cloned by a - * non-refcount means (eg a temp in @_); otherwise they will be - * orphaned - */ - for (i = 0; i<= proto_perl->Itmps_ix; i++) { - SV * const nsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, - proto_perl->Itmps_stack[i])); - if (nsv && !SvREFCNT(nsv)) { - PUSH_EXTEND_MORTAL__SV_C(SvREFCNT_inc_simple(nsv)); - } - } } PL_start_env = proto_perl->Istart_env; /* XXXXXX */ @@ -12344,6 +12556,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param); PL_formtarget = sv_dup(proto_perl->Iformtarget, param); + PL_restartjmpenv = proto_perl->Irestartjmpenv; PL_restartop = proto_perl->Irestartop; PL_in_eval = proto_perl->Iin_eval; PL_delaymagic = proto_perl->Idelaymagic; @@ -12420,6 +12633,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_ptr_table = NULL; } + if (!(flags & CLONEf_COPY_STACKS)) { + unreferenced_to_tmp_stack(param->unreferenced); + } SvREFCNT_dec(param->stashes); @@ -12432,6 +12648,89 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, return my_perl; } +static void +S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced) +{ + PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK; + + if (AvFILLp(unreferenced) > -1) { + SV **svp = AvARRAY(unreferenced); + SV **const last = svp + AvFILLp(unreferenced); + SSize_t count = 0; + + do { + if (!SvREFCNT(*svp)) + ++count; + } while (++svp <= last); + + EXTEND_MORTAL(count); + svp = AvARRAY(unreferenced); + + do { + if (!SvREFCNT(*svp)) + PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(*svp); + } while (++svp <= last); + } + SvREFCNT_dec(unreferenced); +} + +void +Perl_clone_params_del(CLONE_PARAMS *param) +{ + PerlInterpreter *const was = PERL_GET_THX; + PerlInterpreter *const to = param->new_perl; + dTHXa(to); + + PERL_ARGS_ASSERT_CLONE_PARAMS_DEL; + + if (was != to) { + PERL_SET_THX(to); + } + + SvREFCNT_dec(param->stashes); + if (param->unreferenced) + unreferenced_to_tmp_stack(param->unreferenced); + + Safefree(param); + + if (was != to) { + PERL_SET_THX(was); + } +} + +CLONE_PARAMS * +Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to) +{ + /* Need to play this game, as newAV() can call safesysmalloc(), and that + does a dTHX; to get the context from thread local storage. + FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to + a version that passes in my_perl. */ + PerlInterpreter *const was = PERL_GET_THX; + CLONE_PARAMS *param; + + PERL_ARGS_ASSERT_CLONE_PARAMS_NEW; + + if (was != to) { + PERL_SET_THX(to); + } + + /* Given that we've set the context, we can do this unshared. */ + Newx(param, 1, CLONE_PARAMS); + + param->flags = 0; + param->proto_perl = from; + param->new_perl = to; + param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV); + AvREAL_off(param->stashes); + param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV); + AvREAL_off(param->unreferenced); + + if (was != to) { + PERL_SET_THX(was); + } + return param; +} + #endif /* USE_ITHREADS */ /*