X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=d253126c8cb5d0846c25035b54f007e8e89e0058;hb=3246d7a3ad86dfa806dd7e514ae5fd2dacd5c0ef;hp=d344d1cefd79f043c873b99f81a3d9bade6cc691;hpb=e8dda941161b48515d0da4da6e5157084cbd1df0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index d344d1c..d253126 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. @@ -64,7 +64,7 @@ S_write_no_mem(pTHX) PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem)); my_exit(1); - return Nullch; + NORETURN_FUNCTION_END; } /* paranoid version of system's malloc() */ @@ -93,7 +93,11 @@ Perl_safesysmalloc(MEM_SIZE size) DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); if (ptr != Nullch) { #ifdef PERL_TRACK_MEMPOOL - *(tTHX*)ptr = aTHX; + ((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; @@ -101,7 +105,7 @@ Perl_safesysmalloc(MEM_SIZE size) else if (PL_nomemok) return Nullch; else { - return S_write_no_mem(aTHX); + return write_no_mem(); } /*NOTREACHED*/ } @@ -134,10 +138,18 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) #ifdef PERL_TRACK_MEMPOOL where = (Malloc_t)((char*)where-sTHX); size += sTHX; - if (*(tTHX*)where != aTHX) { - /* int *nowhere = NULL; *nowhere = 0; */ + 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) @@ -158,7 +170,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) else if (PL_nomemok) return Nullch; else { - return S_write_no_mem(aTHX); + return write_no_mem(); } /*NOTREACHED*/ } @@ -176,10 +188,24 @@ Perl_safesysfree(Malloc_t where) if (where) { #ifdef PERL_TRACK_MEMPOOL where = (Malloc_t)((char*)where-sTHX); - if (*(tTHX*)where != aTHX) { - /* int *nowhere = NULL; *nowhere = 0; */ + 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); } @@ -214,17 +240,18 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) if (ptr != Nullch) { memset((void*)ptr, 0, size); #ifdef PERL_TRACK_MEMPOOL - *(tTHX*)ptr = aTHX; + ((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 { - return S_write_no_mem(aTHX); - } - /*NOTREACHED*/ + return write_no_mem(); } /* These must be defined when not using Perl's malloc for binary @@ -306,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) @@ -320,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; } @@ -355,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++); @@ -364,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) @@ -851,7 +878,7 @@ Perl_savesharedpv(pTHX_ const char *pv) pvlen = strlen(pv)+1; newaddr = (char*)PerlMemShared_malloc(pvlen); if (!newaddr) { - return S_write_no_mem(aTHX); + return write_no_mem(); } return memcpy(newaddr,pv,pvlen); } @@ -986,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 @@ -1003,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; } } @@ -2550,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; @@ -4298,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); } @@ -5058,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; } @@ -5170,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