X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=77627bda985901253edbf877093a488cf915edde;hb=7d0a29fec2f8bfc7e48abe23f1ebc308287c59c8;hp=3f9da667017de1cabf4f1582c5f86b022a7b1038;hpb=39244528574f0425e97af023e283eee5572107b8;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 3f9da66..77627bd 100644 --- a/sv.c +++ b/sv.c @@ -104,10 +104,6 @@ At the time of very final cleanup, sv_free_arenas() is called from perl_destruct() to physically free all the arenas allocated since the start of the interpreter. -Manipulation of any of the PL_*root pointers is protected by enclosing -LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing -if threads are enabled. - The function visit() scans the SV arenas list, and calls a specified function for each SV it finds which is still live - ie which has an SvTYPE other than all 1's, and a non-zero SvREFCNT. visit() is used by the @@ -157,17 +153,12 @@ Public API: * "A time to plant, and a time to uproot what was planted..." */ -/* - * nice_chunk and nice_chunk size need to be set - * and queried under the protection of sv_mutex - */ void Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size) { dVAR; void *new_chunk; U32 new_chunk_size; - LOCK_SV_MUTEX; new_chunk = (void *)(chunk); new_chunk_size = (chunk_size); if (new_chunk_size > PL_nice_chunk_size) { @@ -177,7 +168,6 @@ Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size) } else { Safefree(chunk); } - UNLOCK_SV_MUTEX; } #ifdef DEBUG_LEAKING_SCALARS @@ -209,7 +199,6 @@ Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size) --PL_sv_count; \ } STMT_END -/* sv_mutex must be held while calling uproot_SV() */ #define uproot_SV(p) \ STMT_START { \ (p) = PL_sv_root; \ @@ -220,7 +209,6 @@ Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size) /* make some more SVs by adding another arena */ -/* sv_mutex must be held while calling more_sv() */ STATIC SV* S_more_sv(pTHX) { @@ -250,12 +238,10 @@ S_new_SV(pTHX) { SV* sv; - LOCK_SV_MUTEX; if (PL_sv_root) uproot_SV(sv); else sv = S_more_sv(aTHX); - UNLOCK_SV_MUTEX; SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; @@ -273,12 +259,10 @@ S_new_SV(pTHX) #else # define new_SV(p) \ STMT_START { \ - LOCK_SV_MUTEX; \ if (PL_sv_root) \ uproot_SV(p); \ else \ (p) = S_more_sv(aTHX); \ - UNLOCK_SV_MUTEX; \ SvANY(p) = 0; \ SvREFCNT(p) = 1; \ SvFLAGS(p) = 0; \ @@ -292,12 +276,10 @@ S_new_SV(pTHX) #define del_SV(p) \ STMT_START { \ - LOCK_SV_MUTEX; \ if (DEBUG_D_TEST) \ del_sv(p); \ else \ plant_SV(p); \ - UNLOCK_SV_MUTEX; \ } STMT_END STATIC void @@ -555,9 +537,6 @@ Perl_sv_clean_all(pTHX) 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. - The arena_sets are themselves stored in an arena, but as arenas - themselves are never freed at run time, there is no need to chain the - arena_sets onto an arena_set root. 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 @@ -568,10 +547,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; @@ -585,8 +561,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]; }; @@ -604,7 +580,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.) */ @@ -619,21 +595,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; inext = aroot; aroot = newroot; PL_body_arenas = (void *) newroot; - DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)*aroot)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot)); } /* ok, now have arena-set with at least 1 empty/available arena-desc */ @@ -711,6 +689,7 @@ Perl_get_arena(pTHX_ size_t arena_size) 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)); @@ -723,10 +702,8 @@ Perl_get_arena(pTHX_ size_t arena_size) #define del_body(thing, root) \ STMT_START { \ void ** const thing_copy = (void **)thing;\ - LOCK_SV_MUTEX; \ *thing_copy = *root; \ *root = (void*)thing_copy; \ - UNLOCK_SV_MUTEX; \ } STMT_END /* @@ -1067,7 +1044,7 @@ S_more_bodies (pTHX_ svtype sv_type) assert(bdp->arena_size); - start = (char*) Perl_get_arena(aTHX_ bdp->arena_size); + start = (char*) Perl_get_arena(aTHX_ bdp->arena_size, sv_type); end = start + bdp->arena_size - body_size; @@ -1097,11 +1074,9 @@ S_more_bodies (pTHX_ svtype sv_type) #define new_body_inline(xpv, sv_type) \ STMT_START { \ void ** const r3wt = &PL_body_roots[sv_type]; \ - LOCK_SV_MUTEX; \ xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \ ? *((void **)(r3wt)) : more_bodies(sv_type)); \ *(r3wt) = *(void**)(xpv); \ - UNLOCK_SV_MUTEX; \ } STMT_END #ifndef PURIFY @@ -3355,7 +3330,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) stype = SvTYPE(sstr); dtype = SvTYPE(dstr); - SvAMAGIC_off(dstr); + (void)SvAMAGIC_off(dstr); if ( SvVOK(dstr) ) { /* need to nuke the magic */ @@ -7193,6 +7168,25 @@ Perl_newSVuv(pTHX_ UV u) } /* +=for apidoc newSV_type + +Creates a new SV, of the type specificied. The reference count for the new SV +is set to 1. + +=cut +*/ + +SV * +Perl_newSV_type(pTHX_ svtype type) +{ + register SV *sv; + + new_SV(sv); + sv_upgrade(sv, type); + return sv; +} + +/* =for apidoc newRV_noinc Creates an RV wrapper for an SV. The reference count for the original @@ -7205,10 +7199,7 @@ SV * Perl_newRV_noinc(pTHX_ SV *tmpRef) { dVAR; - register SV *sv; - - new_SV(sv); - sv_upgrade(sv, SVt_RV); + register SV *sv = newSV_type(SVt_RV); SvTEMP_off(tmpRef); SvRV_set(sv, tmpRef); SvROK_on(sv); @@ -7747,7 +7738,7 @@ Perl_newSVrv(pTHX_ SV *rv, const char *classname) new_SV(sv); SV_CHECK_THINKFIRST_COW_DROP(rv); - SvAMAGIC_off(rv); + (void)SvAMAGIC_off(rv); if (SvTYPE(rv) >= SVt_PVMG) { const U32 refcnt = SvREFCNT(rv); @@ -7772,7 +7763,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; @@ -7924,7 +7915,7 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash) if (Gv_AMG(stash)) SvAMAGIC_on(sv); else - SvAMAGIC_off(sv); + (void)SvAMAGIC_off(sv); if(SvSMAGICAL(tmpRef)) if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar)) @@ -10676,7 +10667,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) break; case SAVEt_PARSER: ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = parser_dup(ptr, param); + TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param); break; default: Perl_croak(aTHX_ @@ -10734,7 +10725,7 @@ without it we only clone the data and zero the stacks, with it we copy the stacks and the new perl interpreter is ready to run at the exact same point as the previous one. The pseudo-fork code uses COPY_STACKS while the -threads->new doesn't. +threads->create doesn't. CLONEf_KEEP_PTR_TABLE perl_clone keeps a ptr_table with the pointer of the old