X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=dacd535f8ed2dac026b411774e1db55d46a1d9ba;hb=404c68920bc89ad702536fbd16b3bceafd287acb;hp=fc9914f92e048522f2861592a0e0ef8196f97b0e;hpb=73d95100627fbb8760df38c23d7563a42cc2b6f6;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index fc9914f..dacd535 100644 --- a/sv.c +++ b/sv.c @@ -443,7 +443,8 @@ static void do_clean_objs(pTHX_ SV *ref) { dVAR; - if (SvROK(ref)) { + assert (SvROK(ref)); + { SV * const target = SvRV(ref); if (SvOBJECT(target)) { DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref))); @@ -469,7 +470,9 @@ static void do_clean_named_objs(pTHX_ SV *sv) { dVAR; - if (SvTYPE(sv) == SVt_PVGV && isGV_with_GP(sv) && GvGP(sv)) { + assert(SvTYPE(sv) == SVt_PVGV); + assert(isGV_with_GP(sv)); + if (GvGP(sv)) { if (( #ifdef PERL_DONT_CREATE_GVSV GvSV(sv) && @@ -504,7 +507,7 @@ Perl_sv_clean_objs(pTHX) visit(do_clean_objs, SVf_ROK, SVf_ROK); #ifndef DISABLE_DESTRUCTOR_KLUDGE /* some barnacles may yet remain, clinging to typeglobs */ - visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK); + visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP); #endif PL_in_clean_objs = FALSE; } @@ -551,7 +554,7 @@ Perl_sv_clean_all(pTHX) arena_descs, each holding info for a single arena. By separating the meta-info from the arena, we recover the 1st slot, formerly borrowed for list management. The arena_set is about the size of an - arena, avoiding the needless malloc overhead of a naive linked-list + arena, avoiding the needless malloc overhead of a naive linked-list. The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused memory in the last arena-set (1/2 on average). In trade, we get @@ -562,10 +565,7 @@ Perl_sv_clean_all(pTHX) struct arena_desc { char *arena; /* the raw storage, allocated aligned */ size_t size; /* its size ~4k typ */ - int unit_type; /* useful for arena audits */ - /* info for sv-heads (eventually) - int count, flags; - */ + U32 misc; /* type, and in future other things. */ }; struct arena_set; @@ -579,8 +579,8 @@ struct arena_set; struct arena_set { struct arena_set* next; - int set_size; /* ie ARENAS_PER_SET */ - int curr; /* index of next available arena-desc */ + unsigned int set_size; /* ie ARENAS_PER_SET */ + unsigned int curr; /* index of next available arena-desc */ struct arena_desc set[ARENAS_PER_SET]; }; @@ -598,7 +598,7 @@ Perl_sv_free_arenas(pTHX) dVAR; SV* sva; SV* svanext; - int i; + unsigned int i; /* Free arenas here, but be careful about fake ones. (We assume contiguity of the fake ones with the corresponding real ones.) */ @@ -613,21 +613,23 @@ Perl_sv_free_arenas(pTHX) } { - struct arena_set *next, *aroot = (struct arena_set*) PL_body_arenas; - - for (; aroot; aroot = next) { - const int max = aroot->curr; - for (i=0; icurr; + while (i--) { assert(aroot->set[i].arena); Safefree(aroot->set[i].arena); } - next = aroot->next; - Safefree(aroot); + aroot = aroot->next; + Safefree(current); } } PL_body_arenas = 0; - for (i=0; icurr >= (*aroot)->set_size) { + if (!aroot || aroot->curr >= aroot->set_size) { + struct arena_set *newroot; Newxz(newroot, 1, struct arena_set); newroot->set_size = ARENAS_PER_SET; - newroot->next = *aroot; - *aroot = newroot; - DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)*aroot)); + newroot->next = aroot; + aroot = newroot; + PL_body_arenas = (void *) newroot; + DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", aroot)); } /* ok, now have arena-set with at least 1 empty/available arena-desc */ - curr = (*aroot)->curr++; - adesc = &((*aroot)->set[curr]); + curr = aroot->curr++; + adesc = &(aroot->set[curr]); assert(!adesc->arena); - Newxz(adesc->arena, arena_size, char); + Newx(adesc->arena, arena_size, char); adesc->size = arena_size; + adesc->misc = misc; DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %d\n", - curr, adesc->arena, arena_size)); + curr, (void*)adesc->arena, arena_size)); return adesc->arena; } @@ -1033,10 +1038,6 @@ static const struct body_details bodies_by_type[] = { #define new_NOARENAZ(details) \ my_safecalloc((details)->body_size + (details)->offset) -#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) -static bool done_sanity_check; -#endif - STATIC void * S_more_bodies (pTHX_ svtype sv_type) { @@ -1046,10 +1047,9 @@ S_more_bodies (pTHX_ svtype sv_type) const size_t body_size = bdp->body_size; char *start; const char *end; - - assert(bdp->arena_size); - #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) + static bool done_sanity_check; + /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global * variables like done_sanity_check. */ if (!done_sanity_check) { @@ -1062,14 +1062,16 @@ S_more_bodies (pTHX_ svtype sv_type) } #endif - start = (char*) Perl_get_arena(aTHX_ bdp->arena_size); + assert(bdp->arena_size); + + start = (char*) Perl_get_arena(aTHX_ bdp->arena_size, sv_type); end = start + bdp->arena_size - body_size; /* 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, + (void*)start, (void*)end, (int)bdp->arena_size, sv_type, (int)body_size, (int)bdp->arena_size / (int)body_size)); @@ -3171,15 +3173,14 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) if (dtype != SVt_PVGV) { 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_PV) { SvPV_free(dstr); SvPV_set(dstr, 0); SvLEN_set(dstr, 0); SvCUR_set(dstr, 0); } - sv_upgrade(dstr, SVt_PVGV); + SvUPGRADE(dstr, SVt_PVGV); (void)SvOK_off(dstr); /* FIXME - why are we doing this, then turning it off and on again below? */ @@ -3339,14 +3340,14 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) if (SvIS_FREED(dstr)) { Perl_croak(aTHX_ "panic: attempt to copy value %" SVf - " to a freed scalar %p", sstr, dstr); + " to a freed scalar %p", SVfARG(sstr), (void *)dstr); } SV_CHECK_THINKFIRST_COW_DROP(dstr); if (!sstr) sstr = &PL_sv_undef; if (SvIS_FREED(sstr)) { - Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p", sstr, - dstr); + Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p", + (void*)sstr, (void*)dstr); } stype = SvTYPE(sstr); dtype = SvTYPE(dstr); @@ -3458,6 +3459,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) break; /* case SVt_BIND: */ + case SVt_PVLV: case SVt_PVGV: if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) { glob_assign_glob(dstr, sstr, dtype); @@ -3467,7 +3469,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) /*FALLTHROUGH*/ case SVt_PVMG: - case SVt_PVLV: if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) { mg_get(sstr); if (SvTYPE(sstr) != stype) { @@ -3706,7 +3707,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvNV_set(dstr, SvNVX(sstr)); } if (sflags & SVp_IOK) { - SvRELEASE_IVX(dstr); + SvOOK_off(dstr); SvIV_set(dstr, SvIVX(sstr)); /* Must do this otherwise some other overloaded use of 0x80000000 gets confused. I guess SVpbm_VALID */ @@ -3778,7 +3779,7 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n", - sstr, dstr); + (void*)sstr, (void*)dstr); sv_dump(sstr); if (dstr) sv_dump(dstr); @@ -4011,9 +4012,9 @@ Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags) (which it can do by means other than releasing copy-on-write Svs) or by changing the other copy-on-write SVs in the loop. */ STATIC void -S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after) +S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after) { - if (len) { /* this SV was SvIsCOW_normal(sv) */ + { /* this SV was SvIsCOW_normal(sv) */ /* we need to find the SV pointing to us. */ SV *current = SV_COW_NEXT_SV(after); @@ -4037,19 +4038,8 @@ S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after) /* Make the SV before us point to the SV after us. */ SV_COW_NEXT_SV_SET(current, after); } - } else { - unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); } } - -int -Perl_sv_release_IVX(pTHX_ register SV *sv) -{ - if (SvIsCOW(sv)) - sv_force_normal_flags(sv, 0); - SvOOK_off(sv); - return 0; -} #endif /* =for apidoc sv_force_normal_flags @@ -4078,7 +4068,11 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) const char * const pvx = SvPVX_const(sv); const STRLEN len = SvLEN(sv); const STRLEN cur = SvCUR(sv); - SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */ + /* next COW sv in the loop. If len is 0 then this is a shared-hash + key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as + we'll fail an assertion. */ + SV * const next = len ? SV_COW_NEXT_SV(sv) : 0; + if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Copy on write: Force normal %ld\n", @@ -4099,7 +4093,11 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) SvCUR_set(sv, cur); *SvEND(sv) = '\0'; } - sv_release_COW(sv, pvx, len, next); + if (len) { + sv_release_COW(sv, pvx, next); + } else { + unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); + } if (DEBUG_C_TEST) { sv_dump(sv); } @@ -4515,9 +4513,6 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam case PERL_MAGIC_regdata: vtable = &PL_vtbl_regdata; break; - case PERL_MAGIC_regdata_names: - vtable = &PL_vtbl_regdata_names; - break; case PERL_MAGIC_regdatum: vtable = &PL_vtbl_regdatum; break; @@ -5162,7 +5157,6 @@ Perl_sv_clear(pTHX_ register SV *sv) } else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ SvREFCNT_dec(LvTARG(sv)); - goto freescalar; case SVt_PVGV: if (isGV_with_GP(sv)) { gp_free((GV*)sv); @@ -5200,8 +5194,12 @@ Perl_sv_clear(pTHX_ register SV *sv) PerlIO_printf(Perl_debug_log, "Copy on write: clear\n"); sv_dump(sv); } - sv_release_COW(sv, SvPVX_const(sv), SvLEN(sv), - SV_COW_NEXT_SV(sv)); + if (SvLEN(sv)) { + sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv)); + } else { + unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); + } + /* And drop it here. */ SvFAKE_off(sv); } else if (SvLEN(sv)) { @@ -5389,7 +5387,7 @@ Perl_sv_len_utf8(pTHX_ register SV *sv) PL_utf8cache = 0; Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf " real %"UVuf" for %"SVf, - (UV) ulen, (UV) real, (void*)sv); + (UV) ulen, (UV) real, SVfARG(sv)); } } } @@ -5547,7 +5545,7 @@ S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, PL_utf8cache = 0; Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf " real %"UVuf" for %"SVf, - (UV) boffset, (UV) real_boffset, (void*)sv); + (UV) boffset, (UV) real_boffset, SVfARG(sv)); } } boffset = real_boffset; @@ -5669,7 +5667,7 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8, SAVEI8(PL_utf8cache); PL_utf8cache = 0; Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf - " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, (void*)sv); + " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv)); } } @@ -5892,7 +5890,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) PL_utf8cache = 0; Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf " real %"UVuf" for %"SVf, - (UV) len, (UV) real_len, (void*)sv); + (UV) len, (UV) real_len, SVfARG(sv)); } } len = real_len; @@ -7386,7 +7384,7 @@ Perl_sv_2io(pTHX_ SV *sv) else io = 0; if (!io) - Perl_croak(aTHX_ "Bad filehandle: %"SVf, (void*)sv); + Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv)); break; } return io; @@ -7478,7 +7476,7 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) LEAVE; if (!GvCVu(gv)) Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"", - (void*)sv); + SVfARG(sv)); } return GvCVu(gv); } @@ -7771,7 +7769,7 @@ Perl_newSVrv(pTHX_ SV *rv, const char *classname) SvROK_on(rv); if (classname) { - HV* const stash = gv_stashpv(classname, TRUE); + HV* const stash = gv_stashpv(classname, GV_ADD); (void)sv_bless(rv, stash); } return sv; @@ -8414,7 +8412,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } if (args && patlen == 3 && pat[0] == '%' && pat[1] == '-' && pat[2] == 'p') { - argsv = va_arg(*args, SV*); + argsv = (SV*)va_arg(*args, void*); sv_catsv(sv, argsv); return; } @@ -8570,7 +8568,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV precis = n; has_precis = TRUE; } - argsv = va_arg(*args, SV*); + argsv = (SV*)va_arg(*args, void*); eptr = SvPVx_const(argsv, elen); if (DO_UTF8(argsv)) is_utf8 = TRUE; @@ -9347,7 +9345,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV (UV)c & 0xFF); } else sv_catpvs(msg, "end of string"); - Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, (void*)msg); /* yes, this is reentrant */ + Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */ } /* output mangled stuff ... */ @@ -9937,7 +9935,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) #ifdef DEBUGGING if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx) PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n", - PL_watch_pvx, SvPVX_const(sstr)); + (void*)PL_watch_pvx, SvPVX_const(sstr)); #endif /* don't clone objects whose class has asked us not to */ @@ -10049,20 +10047,16 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param); else LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param); - break; case SVt_PVGV: if(isGV_with_GP(sstr)) { 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. */ - if(!SvVALID(dstr)) - GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param); - if(isGV_with_GP(sstr)) { + /* Don't call sv_add_backref here as it's going to be + created as part of the magic cloning of the symbol + table. */ /* Danger Will Robinson - GvGP(dstr) isn't initialised at the point of this comment. */ + GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param); GvGP(dstr) = gp_dup(GvGP(sstr), param); (void)GpREFCNT_inc(GvGP(dstr)); } else @@ -11028,6 +11022,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, newSViv(PTR2IV(CALLREGDUPE( INT2PTR(REGEXP *, SvIVX(regex)), param)))) ; + if (SvFLAGS(regex) & SVf_BREAK) + SvFLAGS(sv) |= SVf_BREAK; /* unrefcnted PL_curpm */ av_push(PL_regex_padav, sv); } }