X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=b155eeee948d54b27b14482b980f67896bb1ce7e;hb=b73edd974ff6de4630341da3b93d562a24ff05d7;hp=9fb9985050e4052495aa0e6e5c4ecbd5b4f3c3f0;hpb=760ac839baf413929cd31cc32ffd6dba6b781a81;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 9fb9985..b155eee 100644 --- a/sv.c +++ b/sv.c @@ -45,7 +45,6 @@ static XPVIV *more_xiv _((void)); static XPVNV *more_xnv _((void)); static XPV *more_xpv _((void)); static XRV *more_xrv _((void)); -static SV *new_sv _((void)); static XPVIV *new_xiv _((void)); static XPVNV *new_xnv _((void)); static XPV *new_xpv _((void)); @@ -55,13 +54,95 @@ static void del_xnv _((XPVNV* p)); static void del_xpv _((XPV* p)); static void del_xrv _((XRV* p)); static void sv_mortalgrow _((void)); - static void sv_unglob _((SV* sv)); +typedef void (*SVFUNC) _((SV*)); + #ifdef PURIFY -#define new_SV() sv = (SV*)safemalloc(sizeof(SV)) -#define del_SV(p) free((char*)p) +#define new_SV(p) \ + do { \ + (p) = (SV*)safemalloc(sizeof(SV)); \ + reg_add(p); \ + } while (0) + +#define del_SV(p) \ + do { \ + reg_remove(p); \ + free((char*)(p)); \ + } while (0) + +static SV **registry; +static I32 regsize; + +#define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size)) + +#define REG_REPLACE(sv,a,b) \ + do { \ + void* p = sv->sv_any; \ + I32 h = REGHASH(sv, regsize); \ + I32 i = h; \ + while (registry[i] != (a)) { \ + if (++i >= regsize) \ + i = 0; \ + if (i == h) \ + die("SV registry bug"); \ + } \ + registry[i] = (b); \ + } while (0) + +#define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv) +#define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv) + +static void +reg_add(sv) +SV* sv; +{ + if (sv_count >= (regsize >> 1)) + { + SV **oldreg = registry; + I32 oldsize = regsize; + + regsize = regsize ? ((regsize << 2) + 1) : 2037; + registry = (SV**)safemalloc(regsize * sizeof(SV*)); + memzero(registry, regsize * sizeof(SV*)); + + if (oldreg) { + I32 i; + + for (i = 0; i < oldsize; ++i) { + SV* oldsv = oldreg[i]; + if (oldsv) + REG_ADD(oldsv); + } + Safefree(oldreg); + } + } + + REG_ADD(sv); + ++sv_count; +} + +static void +reg_remove(sv) +SV* sv; +{ + REG_REMOVE(sv); + --sv_count; +} + +static void +visit(f) +SVFUNC f; +{ + I32 i; + + for (i = 0; i < regsize; ++i) { + SV* sv = registry[i]; + if (sv) + (*f)(sv); + } +} void sv_add_arena(ptr, size, flags) @@ -73,40 +154,40 @@ U32 flags; free(ptr); } -#else +#else /* ! PURIFY */ -#define new_SV() \ - if (sv_root) { \ - sv = sv_root; \ - sv_root = (SV*)SvANY(sv); \ +/* + * "A time to plant, and a time to uproot what was planted..." + */ + +#define plant_SV(p) \ + do { \ + SvANY(p) = (void *)sv_root; \ + SvFLAGS(p) = SVTYPEMASK; \ + sv_root = (p); \ + --sv_count; \ + } while (0) + +#define uproot_SV(p) \ + do { \ + (p) = sv_root; \ + sv_root = (SV*)SvANY(p); \ ++sv_count; \ - } \ - else \ - sv = more_sv(); + } while (0) -static SV* -new_sv() -{ - SV* sv; - if (sv_root) { - sv = sv_root; - sv_root = (SV*)SvANY(sv); - ++sv_count; - return sv; - } - return more_sv(); -} +#define new_SV(p) \ + if (sv_root) \ + uproot_SV(p); \ + else \ + (p) = more_sv() #ifdef DEBUGGING + #define del_SV(p) \ if (debug & 32768) \ del_sv(p); \ - else { \ - SvANY(p) = (void *)sv_root; \ - SvFLAGS(p) = SVTYPEMASK; \ - sv_root = p; \ - --sv_count; \ - } + else \ + plant_SV(p) static void del_sv(p) @@ -128,17 +209,14 @@ SV* p; return; } } - SvANY(p) = (void *) sv_root; - sv_root = p; - --sv_count; + plant_SV(p); } -#else -#define del_SV(p) \ - SvANY(p) = (void *)sv_root; \ - sv_root = p; \ - --sv_count; -#endif +#else /* ! DEBUGGING */ + +#define del_SV(p) plant_SV(p) + +#endif /* DEBUGGING */ void sv_add_arena(ptr, size, flags) @@ -173,6 +251,8 @@ U32 flags; static SV* more_sv() { + register SV* sv; + if (nice_chunk) { sv_add_arena(nice_chunk, nice_chunk_size, 0); nice_chunk = Nullch; @@ -182,74 +262,88 @@ more_sv() New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */ sv_add_arena(chunk, 1008, 0); } - return new_sv(); + uproot_SV(sv); + return sv; } -#endif -void -sv_report_used() +static void +visit(f) +SVFUNC f; { SV* sva; SV* sv; register SV* svend; - for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { - sv = sva + 1; + for (sva = sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { svend = &sva[SvREFCNT(sva)]; - while (sv < svend) { - if (SvTYPE(sv) != SVTYPEMASK) { - PerlIO_printf(PerlIO_stderr(), "****\n"); - sv_dump(sv); - } - ++sv; + for (sv = sva + 1; sv < svend; ++sv) { + if (SvTYPE(sv) != SVTYPEMASK) + (*f)(sv); } } } +#endif /* PURIFY */ + +static void +do_report_used(sv) +SV* sv; +{ + if (SvTYPE(sv) != SVTYPEMASK) { + /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */ + PerlIO_printf(PerlIO_stderr(), "****\n"); + sv_dump(sv); + } +} + void -sv_clean_objs() +sv_report_used() +{ + visit(do_report_used); +} + +static void +do_clean_objs(sv) +SV* sv; { - SV* sva; - register SV* sv; - register SV* svend; SV* rv; -#ifndef DISABLE_DESTRUCTOR_KLUDGE - register GV* gv; - for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { - gv = (GV*)sva + 1; - svend = &sva[SvREFCNT(sva)]; - while ((SV*)gv < svend) { - if (SvTYPE(gv) == SVt_PVGV && (sv = GvSV(gv)) && - SvROK(sv) && SvOBJECT(rv = SvRV(sv))) - { - DEBUG_D((PerlIO_printf(PerlIO_stderr(), "Cleaning object ref:\n "), - sv_dump(sv));) - SvROK_off(sv); - SvRV(sv) = 0; - SvREFCNT_dec(rv); - } - ++gv; - } + if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));) + SvROK_off(sv); + SvRV(sv) = 0; + SvREFCNT_dec(rv); } - if (!sv_objcount) - return; + + /* XXX Might want to check arrays, etc. */ +} + +#ifndef DISABLE_DESTRUCTOR_KLUDGE +static void +do_clean_named_objs(sv) +SV* sv; +{ + if (SvTYPE(sv) == SVt_PVGV && GvSV(sv)) + do_clean_objs(GvSV(sv)); +} #endif - for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { - sv = sva + 1; - svend = &sva[SvREFCNT(sva)]; - while (sv < svend) { - if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { - DEBUG_D((PerlIO_printf(PerlIO_stderr(), "Cleaning object ref:\n "), - sv_dump(sv));) - SvROK_off(sv); - SvRV(sv) = 0; - SvREFCNT_dec(rv); - } - /* XXX Might want to check arrays, etc. */ - ++sv; - } - } + +void +sv_clean_objs() +{ +#ifndef DISABLE_DESTRUCTOR_KLUDGE + visit(do_clean_named_objs); +#endif + visit(do_clean_objs); +} + +static void +do_clean_all(sv) +SV* sv; +{ + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops:\n "), sv_dump(sv));) + SvFLAGS(sv) |= SVf_BREAK; + SvREFCNT_dec(sv); } static int in_clean_all = 0; @@ -257,23 +351,8 @@ static int in_clean_all = 0; void sv_clean_all() { - SV* sva; - register SV* sv; - register SV* svend; - in_clean_all = 1; - for (sva = sv_arenaroot; sva; sva = (SV*) SvANY(sva)) { - sv = sva + 1; - svend = &sva[SvREFCNT(sva)]; - while (sv < svend) { - if (SvTYPE(sv) != SVTYPEMASK) { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops:\n "), sv_dump(sv));) - SvFLAGS(sv) |= SVf_BREAK; - SvREFCNT_dec(sv); - } - ++sv; - } - } + visit(do_clean_all); in_clean_all = 0; } @@ -583,7 +662,6 @@ U32 mt; stash = 0; break; case SVt_PV: - nv = 0.0; pv = SvPVX(sv); cur = SvCUR(sv); len = SvLEN(sv); @@ -598,7 +676,6 @@ U32 mt; mt = SVt_PVNV; break; case SVt_PVIV: - nv = 0.0; pv = SvPVX(sv); cur = SvCUR(sv); len = SvLEN(sv); @@ -609,7 +686,6 @@ U32 mt; del_XPVIV(SvANY(sv)); break; case SVt_PVNV: - nv = SvNVX(sv); pv = SvPVX(sv); cur = SvCUR(sv); len = SvLEN(sv); @@ -701,8 +777,8 @@ U32 mt; if (pv) Safefree(pv); SvPVX(sv) = 0; - AvMAX(sv) = 0; - AvFILL(sv) = 0; + AvMAX(sv) = -1; + AvFILL(sv) = -1; SvIVX(sv) = 0; SvNVX(sv) = 0.0; SvMAGIC(sv) = magic; @@ -971,7 +1047,7 @@ unsigned long newlen; #ifdef MSDOS if (newlen >= 0x10000) { - PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", newlen); + PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen); my_exit(1); } #endif /* MSDOS */ @@ -1580,7 +1656,7 @@ register SV *sstr; break; case SVt_PVLV: - sv_upgrade(dstr, SVt_PVNV); + sv_upgrade(dstr, SVt_PVLV); break; case SVt_PVAV: @@ -1809,7 +1885,8 @@ register SV *sv; register char *ptr; register STRLEN len; { - assert(len >= 0); + assert(len >= 0); /* STRLEN is probably unsigned, so this may + elicit a warning, but it won't hurt. */ if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv) && curcop != &compiling) croak(no_modify); @@ -1990,7 +2067,7 @@ STRLEN len; { register SV *sv; - new_SV(); + new_SV(sv); SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; @@ -2077,6 +2154,9 @@ I32 namlen; case 'i': mg->mg_virtual = &vtbl_isaelem; break; + case 'k': + mg->mg_virtual = &vtbl_nkeys; + break; case 'L': SvRMAGICAL_on(sv); mg->mg_virtual = 0; @@ -2520,7 +2600,7 @@ register SV *str2; if (cur1 != cur2) return 0; - return !bcmp(pv1, pv2, cur1); + return !memcmp(pv1, pv2, cur1); } I32 @@ -2534,39 +2614,91 @@ register SV *str2; char *pv2; STRLEN cur2; + if (lc_collate_active) { /* NOTE: this is the LC_COLLATE branch */ + if (!str1) { pv1 = ""; cur1 = 0; - } - else + } else { pv1 = SvPV(str1, cur1); + { + STRLEN cur1x; + char * pv1x = mem_collxfrm(pv1, cur1, &cur1x); + + pv1 = pv1x; + cur1 = cur1x; + } + } + if (!str2) { pv2 = ""; cur2 = 0; + } else { + pv2 = SvPV(str2, cur2); + + { + STRLEN cur2x; + char * pv2x = mem_collxfrm(pv2, cur2, &cur2x); + + pv2 = pv2x; + cur2 = cur2x; + } } + + if (!cur1) { + Safefree(pv2); + return cur2 ? -1 : 0; + } + + if (!cur2) { + Safefree(pv1); + return 1; + } + + retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2); + + Safefree(pv1); + Safefree(pv2); + + if (retval) + return retval < 0 ? -1 : 1; + + if (cur1 == cur2) + return 0; else + return cur1 < cur2 ? -1 : 1; + + } else { /* NOTE: this is the non-LC_COLLATE branch */ + + if (!str1) { + pv1 = ""; + cur1 = 0; + } else + pv1 = SvPV(str1, cur1); + + if (!str2) { + pv2 = ""; + cur2 = 0; + } else pv2 = SvPV(str2, cur2); if (!cur1) return cur2 ? -1 : 0; + if (!cur2) return 1; - if (cur1 < cur2) { - /*SUPPRESS 560*/ - if (retval = memcmp((void*)pv1, (void*)pv2, cur1)) - return retval < 0 ? -1 : 1; - else - return -1; - } - /*SUPPRESS 560*/ - else if (retval = memcmp((void*)pv1, (void*)pv2, cur2)) + retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2); + + if (retval) return retval < 0 ? -1 : 1; - else if (cur1 == cur2) + + if (cur1 == cur2) return 0; else - return 1; + return cur1 < cur2 ? -1 : 1; + } } char * @@ -2635,6 +2767,15 @@ I32 append; STRLEN bpx; I32 shortbuffered; +#if defined(VMS) && defined(PERLIO_IS_STDIO) + /* An ungetc()d char is handled separately from the regular + * buffer, so we getc() it back out and stuff it in the buffer. + */ + i = PerlIO_getc(fp); + if (i == EOF) return 0; + *(--((*fp)->_ptr)) = (unsigned char) i; + (*fp)->_cnt++; +#endif /* Here is some breathtakingly efficient cheating */ @@ -2654,6 +2795,11 @@ I32 append; shortbuffered = 0; bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */ ptr = (STDCHAR*)PerlIO_get_ptr(fp); + DEBUG_P(PerlIO_printf(Perl_debug_log, + "Screamer: entering, ptr=%d, cnt=%d\n",ptr,cnt)); + DEBUG_P(PerlIO_printf(Perl_debug_log, + "Screamer: entering: FILE * thinks ptr=%d, cnt=%d, base=%d\n", + PerlIO_get_ptr(fp), PerlIO_get_cnt(fp), PerlIO_get_base(fp))); for (;;) { screamer: if (cnt > 0) { @@ -2682,14 +2828,26 @@ I32 append; continue; } - PerlIO_set_ptrcnt(fp,(char *) ptr, cnt); /* deregisterize cnt and ptr */ - /* This used to call 'filbuf' in stdio form, but as that behaves like getc - when cnt <= 0 we use PerlIO_getc here to avoid another abstraction. - This may also avoid issues with different named 'filbuf' equivalents + DEBUG_P(PerlIO_printf(Perl_debug_log, + "Screamer: going to getc, ptr=%d, cnt=%d\n",ptr,cnt)); + PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */ + DEBUG_P(PerlIO_printf(Perl_debug_log, + "Screamer: pre: FILE * thinks ptr=%d, cnt=%d, base=%d\n", + PerlIO_get_ptr(fp), PerlIO_get_cnt(fp), PerlIO_get_base(fp))); + /* This used to call 'filbuf' in stdio form, but as that behaves like + getc when cnt <= 0 we use PerlIO_getc here to avoid another + abstraction. This may also avoid issues with different named + 'filbuf' equivalents, though Configure tries to handle them now + anyway. */ i = PerlIO_getc(fp); /* get more characters */ + DEBUG_P(PerlIO_printf(Perl_debug_log, + "Screamer: post: FILE * thinks ptr=%d, cnt=%d, base=%d\n", + PerlIO_get_ptr(fp), PerlIO_get_cnt(fp), PerlIO_get_base(fp))); cnt = PerlIO_get_cnt(fp); ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */ + DEBUG_P(PerlIO_printf(Perl_debug_log, + "Screamer: after getc, ptr=%d, cnt=%d\n",ptr,cnt)); if (i == EOF) /* all done for ever? */ goto thats_really_all_folks; @@ -2707,14 +2865,22 @@ I32 append; thats_all_folks: if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) || - bcmp((char*)bp - rslen, rsptr, rslen)) + memcmp((char*)bp - rslen, rsptr, rslen)) goto screamer; /* go back to the fray */ thats_really_all_folks: if (shortbuffered) cnt += shortbuffered; - PerlIO_set_ptrcnt(fp,(char *) ptr, cnt); /* put these back or we're in trouble */ + DEBUG_P(PerlIO_printf(Perl_debug_log, + "Screamer: quitting, ptr=%d, cnt=%d\n",ptr,cnt)); + PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */ + DEBUG_P(PerlIO_printf(Perl_debug_log, + "Screamer: end: FILE * thinks ptr=%d, cnt=%d, base=%d\n", + PerlIO_get_ptr(fp), PerlIO_get_cnt(fp), PerlIO_get_base(fp))); *bp = '\0'; SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */ + DEBUG_P(PerlIO_printf(Perl_debug_log, + "Screamer: done, len=%d, string=|%.*s|\n", + SvCUR(sv),SvCUR(sv),SvPVX(sv))); } else { @@ -2731,7 +2897,10 @@ screamer2: } else { cnt = PerlIO_read(fp,(char*)buf, sizeof(buf)); - i = cnt ? (U8)buf[cnt - 1] : EOF; + /* Accomodate broken VAXC compiler, which applies U8 cast to + * both args of ?: operator, causing EOF to change into 255 + */ + if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; } } if (append) @@ -2742,7 +2911,7 @@ screamer2: if (i != EOF && /* joy */ (!rslen || SvCUR(sv) < rslen || - bcmp(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen))) + memcmp(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen))) { append = -1; goto screamer2; @@ -2893,7 +3062,7 @@ SV *oldstr; { register SV *sv; - new_SV(); + new_SV(sv); SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; @@ -2910,7 +3079,7 @@ sv_newmortal() { register SV *sv; - new_SV(); + new_SV(sv); SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = SVs_TEMP; @@ -2944,7 +3113,7 @@ STRLEN len; { register SV *sv; - new_SV(); + new_SV(sv); SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; @@ -2960,7 +3129,7 @@ double n; { register SV *sv; - new_SV(); + new_SV(sv); SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; @@ -2974,7 +3143,7 @@ IV i; { register SV *sv; - new_SV(); + new_SV(sv); SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; @@ -2988,7 +3157,7 @@ SV *ref; { register SV *sv; - new_SV(); + new_SV(sv); SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; @@ -3013,7 +3182,7 @@ register SV *old; warn("semi-panic: attempt to dup freed string"); return Nullsv; } - new_SV(); + new_SV(sv); SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; @@ -3145,7 +3314,7 @@ I32 lref; SV *tmpsv; ENTER; tmpsv = NEWSV(704,0); - gv_efullname(tmpsv, gv); + gv_efullname3(tmpsv, gv, Nullch); newSUB(start_subparse(), newSVOP(OP_CONST, 0, tmpsv), Nullop, @@ -3340,7 +3509,7 @@ char *classname; { SV *sv; - new_SV(); + new_SV(sv); SvANY(sv) = 0; SvREFCNT(sv) = 0; SvFLAGS(sv) = 0; @@ -3649,11 +3818,11 @@ SV* sv; PerlIO_printf(Perl_debug_log, " ROOT = 0x%lx\n", (long)CvROOT(sv)); PerlIO_printf(Perl_debug_log, " XSUB = 0x%lx\n", (long)CvXSUB(sv)); PerlIO_printf(Perl_debug_log, " XSUBANY = %ld\n", (long)CvXSUBANY(sv).any_i32); - PerlIO_printf(PerlIO_stderr(), " GV = 0x%lx", (long)CvGV(sv)); + PerlIO_printf(Perl_debug_log, " GV = 0x%lx", (long)CvGV(sv)); if (CvGV(sv) && GvNAME(CvGV(sv))) { - PerlIO_printf(PerlIO_stderr(), " \"%s\"\n", GvNAME(CvGV(sv))); + PerlIO_printf(Perl_debug_log, " \"%s\"\n", GvNAME(CvGV(sv))); } else { - PerlIO_printf(PerlIO_stderr(), "\n"); + PerlIO_printf(Perl_debug_log, "\n"); } PerlIO_printf(Perl_debug_log, " FILEGV = 0x%lx\n", (long)CvFILEGV(sv)); PerlIO_printf(Perl_debug_log, " DEPTH = %ld\n", (long)CvDEPTH(sv));