X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e736a858356e87659136ef1f34af858e253efe45..7bf00c8648fdb39d6fb0cb43bc6fe32aa4ebcf65:/sv.c diff --git a/sv.c b/sv.c index ca61ada..e5e997c 100644 --- a/sv.c +++ b/sv.c @@ -472,7 +472,7 @@ static void do_clean_named_objs(pTHX_ SV *sv) { dVAR; - if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) { + if (SvTYPE(sv) == SVt_PVGV && isGV_with_GP(sv) && GvGP(sv)) { if (( #ifdef PERL_DONT_CREATE_GVSV GvSV(sv) && @@ -587,18 +587,6 @@ struct arena_set { struct arena_desc set[ARENAS_PER_SET]; }; -#if !ARENASETS - -static void -S_free_arena(pTHX_ void **root) { - while (root) { - void ** const next = *(void **)root; - Safefree(root); - root = next; - } -} -#endif - /* =for apidoc sv_free_arenas @@ -627,7 +615,6 @@ Perl_sv_free_arenas(pTHX) Safefree(sva); } -#if ARENASETS { struct arena_set *next, *aroot = (struct arena_set*) PL_body_arenas; @@ -641,9 +628,6 @@ Perl_sv_free_arenas(pTHX) Safefree(aroot); } } -#else - S_free_arena(aTHX_ (void**) PL_body_arenas); -#endif PL_body_arenas = 0; for (i=0; inext = PL_body_arenas; - PL_body_arenas = arp; - return arp; - -#else struct arena_desc* adesc; struct arena_set *newroot, **aroot = (struct arena_set**) &PL_body_arenas; int curr; @@ -737,7 +709,6 @@ Perl_get_arena(pTHX_ int arena_size) curr, adesc->arena, arena_size)); return adesc->arena; -#endif } @@ -875,9 +846,16 @@ struct body_details { limited by PERL_ARENA_SIZE, so we can safely oversize the declarations. */ -#define FIT_ARENA(count, body_size) \ - (!count || count * body_size > PERL_ARENA_SIZE) \ - ? (int)(PERL_ARENA_SIZE / body_size) * body_size : count * body_size +#define FIT_ARENA0(body_size) \ + ((size_t)(PERL_ARENA_SIZE / body_size) * body_size) +#define FIT_ARENAn(count,body_size) \ + ( count * body_size <= PERL_ARENA_SIZE) \ + ? count * body_size \ + : FIT_ARENA0 (body_size) +#define FIT_ARENA(count,body_size) \ + count \ + ? FIT_ARENAn (count, body_size) \ + : FIT_ARENA0 (body_size) /* A macro to work out the offset needed to subtract from a pointer to (say) @@ -1074,7 +1052,7 @@ S_more_bodies (pTHX_ svtype sv_type) #ifdef DEBUGGING if (!done_sanity_check) { - int i = SVt_LAST; + unsigned int i = SVt_LAST; done_sanity_check = TRUE; @@ -1087,17 +1065,11 @@ S_more_bodies (pTHX_ svtype sv_type) end = start + bdp->arena_size - body_size; -#if !ARENASETS - /* The initial slot is used to link the arenas together, so it isn't to be - linked into the list of ready-to-use bodies. */ - start += body_size; -#else /* computed count doesnt reflect the 1st slot reservation */ DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %p end %p arena-size %d type %d size %d ct %d\n", start, end, bdp->arena_size, sv_type, body_size, bdp->arena_size / body_size)); -#endif *root = (void *)start; @@ -1344,9 +1316,21 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type) SvANY(sv) = new_body; if (old_type_details->copy) { - Copy((char *)old_body + old_type_details->offset, - (char *)new_body + old_type_details->offset, - old_type_details->copy, char); + /* There is now the potential for an upgrade from something without + an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */ + int offset = old_type_details->offset; + int length = old_type_details->copy; + + if (new_type_details->offset > old_type_details->offset) { + int difference + = new_type_details->offset - old_type_details->offset; + offset += difference; + length -= difference; + } + assert (length >= 0); + + Copy((char *)old_body + offset, (char *)new_body + offset, length, + char); } #ifndef NV_ZERO_IS_ALLBITS_ZERO @@ -1425,6 +1409,10 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) { register char *s; + if (PL_madskills && newlen >= 0x100000) { + PerlIO_printf(Perl_debug_log, + "Allocation too large: %"UVxf"\n", (UV)newlen); + } #ifdef HAS_64K_LIMIT if (newlen >= 0x10000) { PerlIO_printf(Perl_debug_log, @@ -2117,12 +2105,9 @@ S_sv_2iuv_common(pTHX_ SV *sv) { } } else { - if (((SvFLAGS(sv) & (SVp_POK|SVp_SCREAM)) == SVp_SCREAM) - && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV)) { - return PTR2IV(glob_2inpuv((GV *)sv, NULL, TRUE)); + if (isGV_with_GP(sv)) { + return (bool)PTR2IV(glob_2inpuv((GV *)sv, NULL, TRUE)); } - if (SvTYPE(sv) == SVt_PVGV) - sv_dump(sv); if (!(SvFLAGS(sv) & SVs_PADTMP)) { if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) @@ -2471,8 +2456,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) #endif /* NV_PRESERVES_UV */ } else { - if (((SvFLAGS(sv) & (SVp_POK|SVp_SCREAM)) == SVp_SCREAM) - && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV)) { + if (isGV_with_GP(sv)) { glob_2inpuv((GV *)sv, NULL, TRUE); return 0.0; } @@ -2809,8 +2793,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) #endif } else { - if (((SvFLAGS(sv) & (SVp_POK|SVp_SCREAM)) == SVp_SCREAM) - && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV)) { + if (isGV_with_GP(sv)) { return glob_2inpuv((GV *)sv, lp, FALSE); } @@ -2945,8 +2928,7 @@ Perl_sv_2bool(pTHX_ register SV *sv) if (SvNOKp(sv)) return SvNVX(sv) != 0.0; else { - if ((SvFLAGS(sv) & SVp_SCREAM) - && (SvTYPE(sv) == (SVt_PVGV) || SvTYPE(sv) == (SVt_PVLV))) + if (isGV_with_GP(sv)) return TRUE; else return FALSE; @@ -3189,13 +3171,21 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) const char * const name = GvNAME(sstr); const STRLEN len = GvNAMELEN(sstr); /* don't upgrade SVt_PVLV: it can hold a glob */ - if (dtype != SVt_PVLV) + if (dtype != SVt_PVLV) { + if (dtype >= SVt_PV) { + SvPV_free(dstr); + SvPV_set(dstr, 0); + SvLEN_set(dstr, 0); + SvCUR_set(dstr, 0); + } sv_upgrade(dstr, SVt_PVGV); + (void)SvOK_off(dstr); + SvSCREAM_on(dstr); + } GvSTASH(dstr) = GvSTASH(sstr); if (GvSTASH(dstr)) Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr); - GvNAME(dstr) = savepvn(name, len); - GvNAMELEN(dstr) = len; + gv_name_set((GV *)dstr, name, len, GV_ADD); SvFAKE_on(dstr); /* can coerce to non-glob */ } @@ -3205,10 +3195,11 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) } #endif + gp_free((GV*)dstr); + SvSCREAM_off(dstr); (void)SvOK_off(dstr); SvSCREAM_on(dstr); GvINTRO_off(dstr); /* one-shot flag */ - gp_free((GV*)dstr); GvGP(dstr) = gp_ref(GvGP(sstr)); if (SvTAINTED(sstr)) SvTAINT(dstr); @@ -3324,8 +3315,7 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { } break; } - if (dref) - SvREFCNT_dec(dref); + SvREFCNT_dec(dref); if (SvTAINTED(sstr)) SvTAINT(dstr); return; @@ -3439,10 +3429,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) if (dtype < SVt_PVNV) sv_upgrade(dstr, SVt_PVNV); break; - case SVt_PVAV: - case SVt_PVHV: - case SVt_PVCV: - case SVt_PVIO: + default: { const char * const type = sv_reftype(sstr,0); if (PL_op) @@ -3459,7 +3446,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } /*FALLTHROUGH*/ - default: + case SVt_PVMG: + case SVt_PVLV: + case SVt_PVBM: if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) { mg_get(sstr); if ((int)SvTYPE(sstr) != stype) { @@ -3685,8 +3674,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } } else { - if ((stype == SVt_PVGV || stype == SVt_PVLV) - && (sflags & SVp_SCREAM)) { + if (isGV_with_GP(sstr)) { /* This stringification rule for globs is spread in 3 places. This feels bad. FIXME. */ const U32 wasfake = sflags & SVf_FAKE; @@ -4335,7 +4323,7 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, mg->mg_obj = obj; } else { - mg->mg_obj = SvREFCNT_inc(obj); + mg->mg_obj = SvREFCNT_inc_simple(obj); mg->mg_flags |= MGf_REFCOUNTED; } @@ -4359,7 +4347,7 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, if (namlen > 0) mg->mg_ptr = savepvn(name, namlen); else if (namlen == HEf_SVKEY) - mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name); + mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV*)name); else mg->mg_ptr = (char *) name; } @@ -4573,7 +4561,7 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type) MAGIC** mgp; if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) return 0; - mgp = &SvMAGIC(sv); + mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic); for (mg = *mgp; mg; mg = *mgp) { if (mg->mg_type == type) { const MGVTBL* const vtbl = mg->mg_virtual; @@ -4665,7 +4653,7 @@ Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv) } else { av = newAV(); AvREAL_off(av); - SvREFCNT_inc(av); + SvREFCNT_inc_simple_void(av); } *avp = av; } @@ -5092,7 +5080,9 @@ Perl_sv_clear(pTHX_ register SV *sv) goto freescalar; case SVt_PVGV: gp_free((GV*)sv); - Safefree(GvNAME(sv)); + if (GvNAME_HEK(sv)) { + unshare_hek(GvNAME_HEK(sv)); + } /* If we're in a stash, we don't own a reference to it. However it does have a back reference to us, which needs to be cleared. */ if (GvSTASH(sv)) @@ -5109,7 +5099,7 @@ Perl_sv_clear(pTHX_ register SV *sv) case SVt_PV: case SVt_RV: if (SvROK(sv)) { - SV *target = SvRV(sv); + SV * const target = SvRV(sv); if (SvWEAKREF(sv)) sv_del_backref(target, sv); else @@ -5763,9 +5753,7 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) if (cur1 == cur2) eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1); - if (svrecode) - SvREFCNT_dec(svrecode); - + SvREFCNT_dec(svrecode); if (tpv) Safefree(tpv); @@ -5848,9 +5836,7 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) } } - if (svrecode) - SvREFCNT_dec(svrecode); - + SvREFCNT_dec(svrecode); if (tpv) Safefree(tpv); @@ -6965,10 +6951,10 @@ Perl_newRV_noinc(pTHX_ SV *tmpRef) */ SV * -Perl_newRV(pTHX_ SV *tmpRef) +Perl_newRV(pTHX_ SV *sv) { dVAR; - return newRV_noinc(SvREFCNT_inc(tmpRef)); + return newRV_noinc(SvREFCNT_inc_simple_NN(sv)); } /* @@ -7662,7 +7648,7 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash) if (SvTYPE(tmpRef) != SVt_PVIO) ++PL_sv_objcount; SvUPGRADE(tmpRef, SVt_PVMG); - SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash)); + SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc_simple(stash)); if (Gv_AMG(stash)) SvAMAGIC_on(sv); @@ -7686,21 +7672,24 @@ S_sv_unglob(pTHX_ SV *sv) { dVAR; void *xpvmg; - SV *temp = sv_newmortal(); + SV * const temp = sv_newmortal(); assert(SvTYPE(sv) == SVt_PVGV); SvFAKE_off(sv); gv_efullname3(temp, (GV *) sv, "*"); - if (GvGP(sv)) + if (GvGP(sv)) { gp_free((GV*)sv); + } if (GvSTASH(sv)) { sv_del_backref((SV*)GvSTASH(sv), sv); GvSTASH(sv) = NULL; } - SvSCREAM_off(sv); - Safefree(GvNAME(sv)); GvMULTI_off(sv); + if (GvNAME_HEK(sv)) { + unshare_hek(GvNAME_HEK(sv)); + } + SvSCREAM_off(sv); /* need to keep SvANY(sv) in the right arena */ xpvmg = new_XPVMG(); @@ -9197,6 +9186,7 @@ ptr_table_* functions. #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 av_dup(s,t) (AV*)sv_dup((SV*)s,t) #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t)) #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t) @@ -9369,6 +9359,7 @@ GP * Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param) { GP *ret; + if (!gp) return (GP*)NULL; /* look for it in the table first */ @@ -9517,7 +9508,7 @@ Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv) void Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv) { - PTR_TBL_ENT_t *tblent = S_ptr_table_find(tbl, oldsv); + PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv); PERL_UNUSED_CONTEXT; if (tblent) { @@ -9630,7 +9621,10 @@ Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param) } else { /* Special case - not normally malloced for some reason */ - if ((SvREADONLY(sstr) && SvFAKE(sstr))) { + if (isGV_with_GP(sstr)) { + /* Don't need to do anything here. */ + } + else if ((SvREADONLY(sstr) && SvFAKE(sstr))) { /* A "shared" PV - clone it as "shared" PV */ SvPV_set(dstr, HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)), @@ -9774,7 +9768,8 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) sv_type_details->body_size + sv_type_details->offset, char); #endif - if (sv_type != SVt_PVAV && sv_type != SVt_PVHV) + if (sv_type != SVt_PVAV && sv_type != SVt_PVHV + && !isGV_with_GP(dstr)) Perl_rvpv_dup(aTHX_ dstr, sstr, param); /* The Copy above means that all the source (unduplicated) pointers @@ -9784,8 +9779,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) FIXME - instrument and check that assumption */ if (sv_type >= SVt_PVMG) { HV *ourstash; - if ((sv_type == SVt_PVMG || sv_type == SVt_PVGV) && - (ourstash = OURSTASH(dstr))) { + if ((sv_type == SVt_PVMG) && (ourstash = OURSTASH(dstr))) { OURSTASH_set(dstr, hv_dup_inc(ourstash, param)); } else if (SvMAGIC(dstr)) SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param)); @@ -9815,12 +9809,19 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param); break; case SVt_PVGV: - GvNAME(dstr) = SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr)); - GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param); + if (GvNAME_HEK(dstr)) + 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. */ - GvGP(dstr) = gp_dup(GvGP(dstr), param); - (void)GpREFCNT_inc(GvGP(dstr)); + GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param); + if(isGV_with_GP(sstr)) { + /* Danger Will Robinson - GvGP(dstr) isn't initialised + at the point of this comment. */ + GvGP(dstr) = gp_dup(GvGP(sstr), param); + (void)GpREFCNT_inc(GvGP(dstr)); + } else + Perl_rvpv_dup(aTHX_ dstr, sstr, param); break; case SVt_PVIO: IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param); @@ -10730,8 +10731,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, const I32 len = av_len((AV*)proto_perl->Iregex_padav); SV* const * const regexen = AvARRAY((AV*)proto_perl->Iregex_padav); IV i; - av_push(PL_regex_padav, - sv_dup_inc(regexen[0],param)); + av_push(PL_regex_padav, sv_dup_inc_NN(regexen[0],param)); for(i = 1; i <= len; i++) { const SV * const regex = regexen[i]; SV * const sv = @@ -10908,9 +10908,26 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods); PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i); +#ifdef PERL_MAD + Copy(proto_perl->Inexttoke, PL_nexttoke, 5, NEXTTOKE); + PL_lasttoke = proto_perl->Ilasttoke; + PL_realtokenstart = proto_perl->Irealtokenstart; + PL_faketokens = proto_perl->Ifaketokens; + PL_thismad = proto_perl->Ithismad; + PL_thistoken = proto_perl->Ithistoken; + PL_thisopen = proto_perl->Ithisopen; + PL_thisstuff = proto_perl->Ithisstuff; + PL_thisclose = proto_perl->Ithisclose; + PL_thiswhite = proto_perl->Ithiswhite; + PL_nextwhite = proto_perl->Inextwhite; + PL_skipwhite = proto_perl->Iskipwhite; + PL_endwhite = proto_perl->Iendwhite; + PL_curforce = proto_perl->Icurforce; +#else Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE); Copy(proto_perl->Inexttype, PL_nexttype, 5, I32); PL_nexttoke = proto_perl->Inexttoke; +#endif /* XXX This is probably masking the deeper issue of why * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case: @@ -11140,7 +11157,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, proto_perl->Ttmps_stack[i]); if (nsv && !SvREFCNT(nsv)) { EXTEND_MORTAL(1); - PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc(nsv); + PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv); } } } @@ -11288,7 +11305,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* orphaned? eg threads->new inside BEGIN or use */ if (PL_compcv && ! SvREFCNT(PL_compcv)) { - (void)SvREFCNT_inc(PL_compcv); + SvREFCNT_inc_simple_void(PL_compcv); SAVEFREESV(PL_compcv); }