X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=f868645f2face53d26af88b59b78cee8ac1b4f96;hb=74ac850a5ee417afa60a477ea52af7a8f46a7e5a;hp=b558f7a1214d13a1bd02fde1605d13e3fdca3db1;hpb=7452cf6af2e38d62832bbd8762076e54fa12a70f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index b558f7a..f868645 100644 --- a/util.c +++ b/util.c @@ -1,7 +1,7 @@ /* util.c * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -57,6 +57,16 @@ int putenv(char *); * XXX This advice seems to be widely ignored :-( --AD August 1996. */ +static char * +S_write_no_mem(pTHX) +{ + /* Can't use PerlIO to write as it allocates memory */ + PerlLIO_write(PerlIO_fileno(Perl_error_log), + PL_no_mem, strlen(PL_no_mem)); + my_exit(1); + NORETURN_FUNCTION_END; +} + /* paranoid version of system's malloc() */ Malloc_t @@ -71,6 +81,9 @@ Perl_safesysmalloc(MEM_SIZE size) my_exit(1); } #endif /* HAS_64K_LIMIT */ +#ifdef PERL_TRACK_MEMPOOL + size += sTHX; +#endif #ifdef DEBUGGING if ((long)size < 0) Perl_croak_nocontext("panic: malloc"); @@ -78,16 +91,21 @@ Perl_safesysmalloc(MEM_SIZE size) ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ PERL_ALLOC_CHECK(ptr); DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); - if (ptr != Nullch) + if (ptr != Nullch) { +#ifdef PERL_TRACK_MEMPOOL + ((struct perl_memory_debug_header *)ptr)->interpreter = aTHX; +# ifdef PERL_POISON + ((struct perl_memory_debug_header *)ptr)->size = size; + ((struct perl_memory_debug_header *)ptr)->in_use = PERL_POISON_INUSE; +# endif + ptr = (Malloc_t)((char*)ptr+sTHX); +#endif return ptr; +} else if (PL_nomemok) return Nullch; else { - /* Can't use PerlIO to write as it allocates memory */ - PerlLIO_write(PerlIO_fileno(Perl_error_log), - PL_no_mem, strlen(PL_no_mem)); - my_exit(1); - return Nullch; + return write_no_mem(); } /*NOTREACHED*/ } @@ -117,6 +135,22 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) if (!where) return safesysmalloc(size); +#ifdef PERL_TRACK_MEMPOOL + where = (Malloc_t)((char*)where-sTHX); + size += sTHX; + if (((struct perl_memory_debug_header *)where)->interpreter != aTHX) { + Perl_croak_nocontext("panic: realloc from wrong pool"); + } +# ifdef PERL_POISON + if (((struct perl_memory_debug_header *)where)->size > size) { + const MEM_SIZE freed_up = + ((struct perl_memory_debug_header *)where)->size - size; + char *start_of_freed = ((char *)where) + size; + Poison(start_of_freed, freed_up, char); + } + ((struct perl_memory_debug_header *)where)->size = size; +# endif +#endif #ifdef DEBUGGING if ((long)size < 0) Perl_croak_nocontext("panic: realloc"); @@ -127,16 +161,16 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++)); DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); - if (ptr != Nullch) + if (ptr != Nullch) { +#ifdef PERL_TRACK_MEMPOOL + ptr = (Malloc_t)((char*)ptr+sTHX); +#endif return ptr; + } else if (PL_nomemok) return Nullch; else { - /* Can't use PerlIO to write as it allocates memory */ - PerlLIO_write(PerlIO_fileno(Perl_error_log), - PL_no_mem, strlen(PL_no_mem)); - my_exit(1); - return Nullch; + return write_no_mem(); } /*NOTREACHED*/ } @@ -147,11 +181,32 @@ Free_t Perl_safesysfree(Malloc_t where) { dVAR; -#ifdef PERL_IMPLICIT_SYS +#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL) dTHX; #endif DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); if (where) { +#ifdef PERL_TRACK_MEMPOOL + where = (Malloc_t)((char*)where-sTHX); + if (((struct perl_memory_debug_header *)where)->interpreter != aTHX) { + Perl_croak_nocontext("panic: free from wrong pool"); + } +# ifdef PERL_POISON + { + if (((struct perl_memory_debug_header *)where)->in_use + == PERL_POISON_FREE) { + Perl_croak_nocontext("panic: duplicate free"); + } + if (((struct perl_memory_debug_header *)where)->in_use + != PERL_POISON_INUSE) { + Perl_croak_nocontext("panic: bad free "); + } + ((struct perl_memory_debug_header *)where)->in_use + = PERL_POISON_FREE; + } + Poison(where, ((struct perl_memory_debug_header *)where)->size, char); +# endif +#endif PerlMem_free(where); } } @@ -176,23 +231,27 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) Perl_croak_nocontext("panic: calloc"); #endif size *= count; +#ifdef PERL_TRACK_MEMPOOL + size += sTHX; +#endif ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ PERL_ALLOC_CHECK(ptr); DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size)); if (ptr != Nullch) { memset((void*)ptr, 0, size); +#ifdef PERL_TRACK_MEMPOOL + ((struct perl_memory_debug_header *)ptr)->interpreter = aTHX; +# ifdef PERL_POISON + ((struct perl_memory_debug_header *)ptr)->size = size; + ((struct perl_memory_debug_header *)ptr)->in_use = PERL_POISON_INUSE; +# endif + ptr = (Malloc_t)((char*)ptr+sTHX); +#endif return ptr; } else if (PL_nomemok) return Nullch; - else { - /* Can't use PerlIO to write as it allocates memory */ - PerlLIO_write(PerlIO_fileno(Perl_error_log), - PL_no_mem, strlen(PL_no_mem)); - my_exit(1); - return Nullch; - } - /*NOTREACHED*/ + return write_no_mem(); } /* These must be defined when not using Perl's malloc for binary @@ -274,9 +333,11 @@ Perl_instr(pTHX_ register const char *big, register const char *little) for (x=big,s=little; *s; /**/ ) { if (!*x) return Nullch; - if (*s++ != *x++) { - s--; + if (*s != *x) break; + else { + s++; + x++; } } if (!*s) @@ -288,28 +349,24 @@ Perl_instr(pTHX_ register const char *big, register const char *little) /* same as instr but allow embedded nulls */ char * -Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend) +Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend) { - register const I32 first = *little; - register const char * const littleend = lend; - - if (!first && little >= littleend) - return (char*)big; - if (bigend - big < littleend - little) - return Nullch; - bigend -= littleend - little++; - while (big <= bigend) { - register const char *s, *x; - if (*big++ != first) - continue; - for (x=big,s=little; s < littleend; /**/ ) { - if (*s++ != *x++) { - s--; - break; - } - } - if (s >= littleend) - return (char*)(big-1); + if (little >= lend) + return (char*)big; + { + char first = *little++; + const char *s, *x; + bigend -= lend - little; + OUTER: + while (big <= bigend) { + if (*big++ != first) + goto OUTER; + for (x=big,s=little; s < lend; x++,s++) { + if (*s != *x) + goto OUTER; + } + return (char*)(big-1); + } } return Nullch; } @@ -323,7 +380,7 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit register const I32 first = *little; register const char * const littleend = lend; - if (!first && little >= littleend) + if (little >= littleend) return (char*)bigend; bigbeg = big; big = bigend - (littleend - little++); @@ -332,9 +389,11 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit if (*big-- != first) continue; for (x=big+2,s=little; s < littleend; /**/ ) { - if (*s++ != *x++) { - s--; + if (*s != *x) break; + else { + x++; + s++; } } if (s >= littleend) @@ -373,7 +432,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) if (flags & FBMcf_TAIL) { MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; - sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */ + sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */ if (mg && mg->mg_len >= 0) mg->mg_len++; } @@ -819,9 +878,7 @@ Perl_savesharedpv(pTHX_ const char *pv) pvlen = strlen(pv)+1; newaddr = (char*)PerlMemShared_malloc(pvlen); if (!newaddr) { - PerlLIO_write(PerlIO_fileno(Perl_error_log), - PL_no_mem, strlen(PL_no_mem)); - my_exit(1); + return write_no_mem(); } return memcpy(newaddr,pv,pvlen); } @@ -857,7 +914,7 @@ S_mess_alloc(pTHX) XPVMG *any; if (!PL_dirty) - return sv_2mortal(newSVpvn("",0)); + return sv_2mortal(newSVpvs("")); if (PL_mess_sv) return PL_mess_sv; @@ -956,12 +1013,12 @@ S_closest_cop(pTHX_ COP *cop, const OP *o) { /* Look for PL_op starting from o. cop is the last COP we've seen. */ - if (!o || o == PL_op) return cop; + if (!o || o == PL_op) + return cop; if (o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) - { + for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { COP *new_cop; /* If the OP_NEXTSTATE has been optimised away we can still use it @@ -973,7 +1030,8 @@ S_closest_cop(pTHX_ COP *cop, const OP *o) /* Keep searching, and return when we've found something. */ new_cop = closest_cop(cop, kid); - if (new_cop) return new_cop; + if (new_cop) + return new_cop; } } @@ -2520,8 +2578,7 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler) return PerlProc_signal(signo, handler); } -static -Signal_t +static Signal_t sig_trap(int signo) { dVAR; @@ -2658,7 +2715,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) if ((entry = hv_iternext(PL_pidstatus))) { SV * const sv = hv_iterval(PL_pidstatus,entry); I32 len; - const char *spid = hv_iterkey(entry,&len); + const char * const spid = hv_iterkey(entry,&len); assert (len == sizeof(Pid_t)); memcpy((char *)&pid, spid, len); @@ -2840,7 +2897,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, #endif /* additional extensions to try in each dir if scriptname not found */ #ifdef SEARCH_EXTS - const char *const exts[] = { SEARCH_EXTS }; + static const char *const exts[] = { SEARCH_EXTS }; const char *const *const ext = search_ext ? search_ext : exts; int extidx = 0, i = 0; const char *curext = Nullch; @@ -3759,7 +3816,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv) * size from the heap if they are given a NULL buffer pointer. * The problem is that this behaviour is not portable. */ if (getcwd(buf, sizeof(buf) - 1)) { - sv_setpvn(sv, buf, strlen(buf)); + sv_setpv(sv, buf); return TRUE; } else { @@ -4251,14 +4308,14 @@ Perl_vnumify(pTHX_ SV *vs) /* attempt to retrieve the version array */ if ( !(av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)) ) ) { - sv_catpvn(sv,"0",1); + sv_catpvs(sv,"0"); return sv; } len = av_len(av); if ( len == -1 ) { - sv_catpvn(sv,"0",1); + sv_catpvs(sv,"0"); return sv; } @@ -4268,7 +4325,7 @@ Perl_vnumify(pTHX_ SV *vs) { digit = SvIV(*av_fetch(av, i, 0)); if ( width < 3 ) { - const int denom = (int)pow(10,(3-width)); + const int denom = (width == 2 ? 10 : 100); const div_t term = div((int)PERL_ABS(digit),denom); Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem); } @@ -4281,12 +4338,12 @@ Perl_vnumify(pTHX_ SV *vs) { digit = SvIV(*av_fetch(av, len, 0)); if ( alpha && width == 3 ) /* alpha version */ - sv_catpvn(sv,"_",1); + sv_catpvs(sv,"_"); Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit); } else /* len == 0 */ { - sv_catpvn(sv,"000",3); + sv_catpvs(sv, "000"); } return sv; } @@ -4325,7 +4382,7 @@ Perl_vnormal(pTHX_ SV *vs) len = av_len(av); if ( len == -1 ) { - sv_catpvn(sv,"",0); + sv_catpvs(sv,""); return sv; } digit = SvIV(*av_fetch(av, 0, 0)); @@ -4347,7 +4404,7 @@ Perl_vnormal(pTHX_ SV *vs) if ( len <= 2 ) { /* short version, must be at least three */ for ( len = 2 - len; len != 0; len-- ) - sv_catpvn(sv,".0",2); + sv_catpvs(sv,".0"); } return sv; } @@ -5028,7 +5085,7 @@ Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t " %s = %"IVdf": %"UVxf"\n", filename, linenumber, funcname, n, typesize, typename, n * typesize, PTR2UV(newalloc)); - PerlLIO_write(2, buf, len)); + PerlLIO_write(2, buf, len); #endif return newalloc; } @@ -5140,6 +5197,46 @@ Perl_my_clearenv(pTHX) #endif /* PERL_MICRO */ } +#ifdef PERL_IMPLICIT_CONTEXT + +/* implements the MY_CXT_INIT macro. The first time a module is loaded, +the global PL_my_cxt_index is incremented, and that value is assigned to +that module's static my_cxt_index (who's address is passed as an arg). +Then, for each interpreter this function is called for, it makes sure a +void* slot is available to hang the static data off, by allocating or +extending the interpreter's PL_my_cxt_list array */ + +void * +Perl_my_cxt_init(pTHX_ int *index, size_t size) +{ + void *p; + if (*index == -1) { + /* this module hasn't been allocated an index yet */ + MUTEX_LOCK(&PL_my_ctx_mutex); + *index = PL_my_cxt_index++; + MUTEX_UNLOCK(&PL_my_ctx_mutex); + } + + /* make sure the array is big enough */ + if (PL_my_cxt_size <= *index) { + if (PL_my_cxt_size) { + while (PL_my_cxt_size <= *index) + PL_my_cxt_size *= 2; + Renew(PL_my_cxt_list, PL_my_cxt_size, void *); + } + else { + PL_my_cxt_size = 16; + Newx(PL_my_cxt_list, PL_my_cxt_size, void *); + } + } + /* newSV() allocates one more than needed */ + p = (void*)SvPVX(newSV(size-1)); + PL_my_cxt_list[*index] = p; + Zero(p, size, char); + return p; +} +#endif + /* * Local variables: * c-indentation-style: bsd