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() */
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");
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
+ *(tTHX*)ptr = aTHX;
+ ptr = (Malloc_t)((char*)ptr+sTHX);
+#endif
return ptr;
+}
else if (PL_nomemok)
return Nullch;
else {
- return S_write_no_mem(aTHX);
+ return write_no_mem();
}
/*NOTREACHED*/
}
if (!where)
return safesysmalloc(size);
+#ifdef PERL_TRACK_MEMPOOL
+ where = (Malloc_t)((char*)where-sTHX);
+ size += sTHX;
+ if (*(tTHX*)where != aTHX) {
+ /* int *nowhere = NULL; *nowhere = 0; */
+ Perl_croak_nocontext("panic: realloc from wrong pool");
+ }
+#endif
#ifdef DEBUGGING
if ((long)size < 0)
Perl_croak_nocontext("panic: realloc");
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 {
- return S_write_no_mem(aTHX);
+ return write_no_mem();
}
/*NOTREACHED*/
}
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 (*(tTHX*)where != aTHX) {
+ /* int *nowhere = NULL; *nowhere = 0; */
+ Perl_croak_nocontext("panic: free from wrong pool");
+ }
+#endif
PerlMem_free(where);
}
}
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
+ *(tTHX*)ptr = aTHX;
+ 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
for (x=big,s=little; *s; /**/ ) {
if (!*x)
return Nullch;
- if (*s++ != *x++) {
- s--;
+ if (*s != *x)
break;
+ else {
+ s++;
+ x++;
}
}
if (!*s)
if (*big++ != first)
continue;
for (x=big,s=little; s < littleend; /**/ ) {
- if (*s++ != *x++) {
- s--;
+ if (*s != *x)
break;
+ else {
+ s++;
+ x++;
}
}
if (s >= littleend)
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)
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);
}
{
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);
}
" %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;
}