X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=e5e997c10b977404a9633b0609db4a79f41dc35b;hb=5b5cf8d2a2291946fc318cadec7c0c58e74bd1aa;hp=5fc24dc95dd525d7541a731c29c3d1e3f20a18fb;hpb=0c9fdfe0a220af6cdc459e17e5ee8f6fa8946cf7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 5fc24dc..e5e997c 100644 --- a/sv.c +++ b/sv.c @@ -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 } @@ -1081,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; @@ -1094,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; @@ -1351,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 @@ -1432,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, @@ -2125,7 +2106,7 @@ S_sv_2iuv_common(pTHX_ SV *sv) { } else { if (isGV_with_GP(sv)) { - return PTR2IV(glob_2inpuv((GV *)sv, NULL, TRUE)); + return (bool)PTR2IV(glob_2inpuv((GV *)sv, NULL, TRUE)); } if (!(SvFLAGS(sv) & SVs_PADTMP)) { @@ -3204,8 +3185,7 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) 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 */ } @@ -3449,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) @@ -3469,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) { @@ -5101,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)) @@ -6970,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_simple(tmpRef)); + return newRV_noinc(SvREFCNT_inc_simple_NN(sv)); } /* @@ -7705,7 +7686,9 @@ S_sv_unglob(pTHX_ SV *sv) GvSTASH(sv) = NULL; } GvMULTI_off(sv); - Safefree(GvNAME(sv)); + if (GvNAME_HEK(sv)) { + unshare_hek(GvNAME_HEK(sv)); + } SvSCREAM_off(sv); /* need to keep SvANY(sv) in the right arena */ @@ -9203,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) @@ -9825,7 +9809,9 @@ 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)); + 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. */ GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param); @@ -10745,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 = @@ -10923,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: