X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=dacd535f8ed2dac026b411774e1db55d46a1d9ba;hb=da51bb9b4f7f527464b5e38aca8bcb956de1bbbc;hp=2d4fc3910ab8c7066c5e795ea38f09179fc3dd1a;hpb=0d092c369b1b264b1238936288c807173152e270;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 2d4fc39..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, (void*)adesc->arena, arena_size)); @@ -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,7 +1062,9 @@ 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; @@ -3457,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); @@ -3466,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) { @@ -3705,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 */ @@ -4010,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); @@ -4036,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 @@ -4077,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", @@ -4098,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); } @@ -5158,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); @@ -5196,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)) { @@ -7767,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; @@ -10045,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