X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=malloc.c;h=00c387ed6c6a95f760fd49430a29ebbb886f3eda;hb=345d73cfd9677ddcbcfc43412ba14d8c2d2004dd;hp=450142d452bb6fde379ddc2569a9ef86ad171562;hpb=c529f79d594c53d3968d464c57ac24a21137dd09;p=p5sagit%2Fp5-mst-13.2.git diff --git a/malloc.c b/malloc.c index 450142d..00c387e 100644 --- a/malloc.c +++ b/malloc.c @@ -3,6 +3,10 @@ */ /* + * "'The Chamber of Records,' said Gimli. 'I guess that is where we now stand.'" + */ + +/* Here are some notes on configuring Perl's malloc. (For non-perl usage see below.) @@ -125,6 +129,9 @@ # Type of size argument for allocation functions MEM_SIZE unsigned long + # size of void* + PTRSIZE 4 + # Maximal value in LONG LONG_MAX 0x7FFFFFFF @@ -143,12 +150,18 @@ # Fatal error reporting function croak(format, arg) warn(idem) + exit(1) + # Fatal error reporting function + croak2(format, arg1, arg2) warn2(idem) + exit(1) + # Error reporting function warn(format, arg) fprintf(stderr, idem) + # Error reporting function + warn2(format, arg1, arg2) fprintf(stderr, idem) + # Locking/unlocking for MT operation - MALLOC_LOCK MUTEX_LOCK_NOCONTEXT(&PL_malloc_mutex) - MALLOC_UNLOCK MUTEX_UNLOCK_NOCONTEXT(&PL_malloc_mutex) + MALLOC_LOCK MUTEX_LOCK(&PL_malloc_mutex) + MALLOC_UNLOCK MUTEX_UNLOCK(&PL_malloc_mutex) # Locking/unlocking mutex for MT operation MUTEX_LOCK(l) void @@ -231,7 +244,12 @@ # include "perl.h" # if defined(PERL_IMPLICIT_CONTEXT) # define croak Perl_croak_nocontext +# define croak2 Perl_croak_nocontext # define warn Perl_warn_nocontext +# define warn2 Perl_warn_nocontext +# else +# define croak2 croak +# define warn2 warn # endif #else # ifdef PERL_FOR_X2P @@ -241,10 +259,12 @@ # include # include # include -# define _(arg) arg # ifndef Malloc_t # define Malloc_t void * # endif +# ifndef PTRSIZE +# define PTRSIZE 4 +# endif # ifndef MEM_SIZE # define MEM_SIZE unsigned long # endif @@ -268,9 +288,15 @@ # ifndef croak /* make depend */ # define croak(mess, arg) (warn((mess), (arg)), exit(1)) # endif +# ifndef croak2 /* make depend */ +# define croak2(mess, arg1, arg2) (warn2((mess), (arg1), (arg2)), exit(1)) +# endif # ifndef warn # define warn(mess, arg) fprintf(stderr, (mess), (arg)) # endif +# ifndef warn2 +# define warn2(mess, arg1) fprintf(stderr, (mess), (arg1), (arg2)) +# endif # ifdef DEBUG_m # undef DEBUG_m # endif @@ -281,7 +307,11 @@ # ifndef pTHX # define pTHX void # define pTHX_ -# define dTHX extern int Perl___notused +# ifdef HASATTRIBUTE +# define dTHX extern int Perl___notused PERL_UNUSED_DECL +# else +# define dTHX extern int Perl___notused +# endif # define WITH_THX(s) s # endif # ifndef PERL_GET_INTERP @@ -313,11 +343,11 @@ #endif #ifndef MALLOC_LOCK -# define MALLOC_LOCK MUTEX_LOCK_NOCONTEXT(&PL_malloc_mutex) +# define MALLOC_LOCK MUTEX_LOCK(&PL_malloc_mutex) #endif #ifndef MALLOC_UNLOCK -# define MALLOC_UNLOCK MUTEX_UNLOCK_NOCONTEXT(&PL_malloc_mutex) +# define MALLOC_UNLOCK MUTEX_UNLOCK(&PL_malloc_mutex) #endif # ifndef fatalcroak /* make depend */ @@ -326,12 +356,26 @@ #ifdef DEBUGGING # undef DEBUG_m -# define DEBUG_m(a) \ +# define DEBUG_m(a) \ STMT_START { \ - if (PERL_GET_INTERP) { dTHX; if (PL_debug & 128) { a; } } \ + if (PERL_GET_INTERP) { \ + dTHX; \ + if (DEBUG_m_TEST) { \ + PL_debug &= ~DEBUG_m_FLAG; \ + a; \ + PL_debug |= DEBUG_m_FLAG; \ + } \ + } \ } STMT_END #endif +#ifdef PERL_IMPLICIT_CONTEXT +# define PERL_IS_ALIVE aTHX +#else +# define PERL_IS_ALIVE TRUE +#endif + + /* * Layout of memory: * ~~~~~~~~~~~~~~~~ @@ -428,8 +472,13 @@ union overhead { double strut; /* alignment problems */ #endif struct { - u_char ovu_magic; /* magic number */ +/* + * Keep the ovu_index and ovu_magic in this order, having a char + * field first gives alignment indigestion in some systems, such as + * MachTen. + */ u_char ovu_index; /* bucket # */ + u_char ovu_magic; /* magic number */ #ifdef RCHECK u_short ovu_size; /* actual block size */ u_int ovu_rmagic; /* range magic number */ @@ -815,11 +864,17 @@ static char bucket_of[] = # define SBRK_FAILURE_PRICE 50 #endif -#if defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE) +static void morecore (register int bucket); +# if defined(DEBUGGING) +static void botch (char *diag, char *s); +# endif +static void add_to_chain (void *p, MEM_SIZE size, MEM_SIZE chip); +static void* get_from_chain (MEM_SIZE size); +static void* get_from_bigger_buckets(int bucket, MEM_SIZE size); +static union overhead *getpages (MEM_SIZE needed, int *nblksp, int bucket); +static int getpages_adjacent(MEM_SIZE require); -# ifndef BIG_SIZE -# define BIG_SIZE (1<<16) /* 64K */ -# endif +#ifdef PERL_CORE #ifdef I_MACH_CTHREADS # undef MUTEX_LOCK @@ -828,30 +883,66 @@ static char bucket_of[] = # define MUTEX_UNLOCK(m) STMT_START { if (*m) mutex_unlock(*m); } STMT_END #endif -static char *emergency_buffer; -static MEM_SIZE emergency_buffer_size; +#ifndef BITS_IN_PTR +# define BITS_IN_PTR (8*PTRSIZE) +#endif -static int findbucket (union overhead *freep, int srchlen); -static void morecore (register int bucket); -# if defined(DEBUGGING) -static void botch (char *diag, char *s); +/* + * nextf[i] is the pointer to the next free block of size 2^i. The + * smallest allocatable block is 8 bytes. The overhead information + * precedes the data area returned to the user. + */ +#define NBUCKETS (BITS_IN_PTR*BUCKETS_PER_POW2 + 1) +static union overhead *nextf[NBUCKETS]; + +#if defined(PURIFY) && !defined(USE_PERL_SBRK) +# define USE_PERL_SBRK +#endif + +#ifdef USE_PERL_SBRK +# define sbrk(a) Perl_sbrk(a) +Malloc_t Perl_sbrk (int size); +#else +# ifndef HAS_SBRK_PROTO /* usually takes care of this */ +extern Malloc_t sbrk(int); +# endif +#endif + +#ifdef DEBUGGING_MSTATS +/* + * nmalloc[i] is the difference between the number of mallocs and frees + * for a given block size. + */ +static u_int nmalloc[NBUCKETS]; +static u_int sbrk_slack; +static u_int start_slack; +#else /* !( defined DEBUGGING_MSTATS ) */ +# define sbrk_slack 0 +#endif + +static u_int goodsbrk; + +# ifdef PERL_EMERGENCY_SBRK + +# ifndef BIG_SIZE +# define BIG_SIZE (1<<16) /* 64K */ # endif -static void add_to_chain (void *p, MEM_SIZE size, MEM_SIZE chip); -static Malloc_t emergency_sbrk (MEM_SIZE size); -static void* get_from_chain (MEM_SIZE size); -static void* get_from_bigger_buckets(int bucket, MEM_SIZE size); -static union overhead *getpages (int needed, int *nblksp, int bucket); -static int getpages_adjacent(int require); + +static char *emergency_buffer; +static MEM_SIZE emergency_buffer_size; +static MEM_SIZE no_mem; /* 0 if the last request for more memory succeeded. + Otherwise the size of the failing request. */ static Malloc_t emergency_sbrk(MEM_SIZE size) { MEM_SIZE rsize = (((size - 1)>>LOG_OF_MIN_ARENA) + 1)<= BIG_SIZE) { - /* Give the possibility to recover: */ + if (size >= BIG_SIZE && (!no_mem || (size < no_mem))) { + /* Give the possibility to recover, but avoid an infinite cycle. */ MALLOC_UNLOCK; - croak("Out of memory during \"large\" request for %i bytes", size); + no_mem = size; + croak2("Out of memory during \"large\" request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack)); } if (emergency_buffer_size >= rsize) { @@ -899,45 +990,15 @@ emergency_sbrk(MEM_SIZE size) } do_croak: MALLOC_UNLOCK; - croak("Out of memory during request for %i bytes", size); + croak("Out of memory during request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack)); + /* NOTREACHED */ + return Nullch; } -#else /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */ +# else /* !defined(PERL_EMERGENCY_SBRK) */ # define emergency_sbrk(size) -1 -#endif /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */ - -/* - * nextf[i] is the pointer to the next free block of size 2^i. The - * smallest allocatable block is 8 bytes. The overhead information - * precedes the data area returned to the user. - */ -#define NBUCKETS (32*BUCKETS_PER_POW2 + 1) -static union overhead *nextf[NBUCKETS]; - -#ifdef USE_PERL_SBRK -#define sbrk(a) Perl_sbrk(a) -Malloc_t Perl_sbrk (int size); -#else -#ifdef DONT_DECLARE_STD -#ifdef I_UNISTD -#include -#endif -#else -extern Malloc_t sbrk(int); -#endif -#endif - -#ifdef DEBUGGING_MSTATS -/* - * nmalloc[i] is the difference between the number of mallocs and frees - * for a given block size. - */ -static u_int nmalloc[NBUCKETS]; -static u_int sbrk_slack; -static u_int start_slack; -#endif - -static u_int goodsbrk; +# endif +#endif /* ifdef PERL_CORE */ #ifdef DEBUGGING #undef ASSERT @@ -945,6 +1006,7 @@ static u_int goodsbrk; static void botch(char *diag, char *s) { + dTHX; PerlIO_printf(PerlIO_stderr(), "assertion botched (%s?): %s\n", diag, s); PerlProc_abort(); } @@ -993,7 +1055,9 @@ Perl_malloc(register size_t nbytes) POW2_OPTIMIZE_ADJUST(nbytes); nbytes += M_OVERHEAD; nbytes = (nbytes + 3) &~ 3; +#if defined(PACK_MALLOC) && !defined(SMALL_BUCKET_VIA_TABLE) do_shifts: +#endif shiftr = (nbytes - 1) >> START_SHIFT; bucket = START_SHIFTS_BUCKET; /* apart from this loop, this is O(1) */ @@ -1013,7 +1077,32 @@ Perl_malloc(register size_t nbytes) { dTHX; if (!PL_nomemok) { - PerlIO_puts(PerlIO_stderr(),"Out of memory!\n"); +#if defined(PLAIN_MALLOC) && defined(NO_FANCY_MALLOC) + PerlIO_puts(PerlIO_stderr(),"Out of memory!\n"); +#else + char buff[80]; + char *eb = buff + sizeof(buff) - 1; + char *s = eb; + size_t n = nbytes; + + PerlIO_puts(PerlIO_stderr(),"Out of memory during request for "); +#if defined(DEBUGGING) || defined(RCHECK) + n = size; +#endif + *s = 0; + do { + *--s = '0' + (n % 10); + } while (n /= 10); + PerlIO_puts(PerlIO_stderr(),s); + PerlIO_puts(PerlIO_stderr()," bytes, total sbrk() is "); + s = eb; + n = goodsbrk + sbrk_slack; + do { + *--s = '0' + (n % 10); + } while (n /= 10); + PerlIO_puts(PerlIO_stderr(),s); + PerlIO_puts(PerlIO_stderr()," bytes!\n"); +#endif /* defined(PLAIN_MALLOC) && defined(NO_FANCY_MALLOC) */ my_exit(1); } } @@ -1021,21 +1110,31 @@ Perl_malloc(register size_t nbytes) return (NULL); } - DEBUG_m(PerlIO_printf(Perl_debug_log, - "0x%lx: (%05lu) malloc %ld bytes\n", - (unsigned long)(p+1), (unsigned long)(PL_an++), - (long)size)); - /* remove from linked list */ #if defined(RCHECK) - if ((PTR2UV(p)) & (MEM_ALIGNBYTES - 1)) - PerlIO_printf(PerlIO_stderr(), "Corrupt malloc ptr 0x%lx at 0x%lx\n", - (unsigned long)*((int*)p),(unsigned long)p); + if ((PTR2UV(p)) & (MEM_ALIGNBYTES - 1)) { + dTHX; + PerlIO_printf(PerlIO_stderr(), + "Unaligned pointer in the free chain 0x%"UVxf"\n", + PTR2UV(p)); + } + if ((PTR2UV(p->ov_next)) & (MEM_ALIGNBYTES - 1)) { + dTHX; + PerlIO_printf(PerlIO_stderr(), + "Unaligned `next' pointer in the free " + "chain 0x%"UVxf" at 0x%"UVxf"\n", + PTR2UV(p->ov_next), PTR2UV(p)); + } #endif nextf[bucket] = p->ov_next; MALLOC_UNLOCK; + DEBUG_m(PerlIO_printf(Perl_debug_log, + "0x%"UVxf": (%05lu) malloc %ld bytes\n", + PTR2UV(p), (unsigned long)(PL_an++), + (long)size)); + #ifdef IGNORE_SMALL_BAD_FREE if (bucket >= FIRST_BUCKET_WITH_CHECK) #endif @@ -1068,7 +1167,7 @@ Perl_malloc(register size_t nbytes) static char *last_sbrk_top; static char *last_op; /* This arena can be easily extended. */ -static int sbrked_remains; +static MEM_SIZE sbrked_remains; static int sbrk_good = SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE; #ifdef DEBUGGING_MSTATS @@ -1166,14 +1265,14 @@ get_from_bigger_buckets(int bucket, MEM_SIZE size) } static union overhead * -getpages(int needed, int *nblksp, int bucket) +getpages(MEM_SIZE needed, int *nblksp, int bucket) { /* Need to do (possibly expensive) system call. Try to optimize it for rare calling. */ MEM_SIZE require = needed - sbrked_remains; char *cp; union overhead *ovp; - int slack = 0; + MEM_SIZE slack = 0; if (sbrk_good > 0) { if (!last_sbrk_top && require < FIRST_SBRK) @@ -1311,6 +1410,9 @@ getpages(int needed, int *nblksp, int bucket) sbrked_remains = require - needed; last_op = cp; } +#if !defined(PLAIN_MALLOC) && !defined(NO_FANCY_MALLOC) + no_mem = 0; +#endif last_sbrk_top = cp + require; #ifdef DEBUGGING_MSTATS goodsbrk += require; @@ -1319,7 +1421,7 @@ getpages(int needed, int *nblksp, int bucket) } static int -getpages_adjacent(int require) +getpages_adjacent(MEM_SIZE require) { if (require <= sbrked_remains) { sbrked_remains -= require; @@ -1470,8 +1572,8 @@ Perl_mfree(void *mp) #endif DEBUG_m(PerlIO_printf(Perl_debug_log, - "0x%lx: (%05lu) free\n", - (unsigned long)cp, (unsigned long)(PL_an++))); + "0x%"UVxf": (%05lu) free\n", + PTR2UV(cp), (unsigned long)(PL_an++))); if (cp == NULL) return; @@ -1489,17 +1591,36 @@ Perl_mfree(void *mp) { static int bad_free_warn = -1; if (bad_free_warn == -1) { + dTHX; char *pbf = PerlEnv_getenv("PERL_BADFREE"); bad_free_warn = (pbf) ? atoi(pbf) : 1; } if (!bad_free_warn) return; #ifdef RCHECK - warn("%s free() ignored", +#ifdef PERL_CORE + { + dTHX; + if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC)) + Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s free() ignored (RMAGIC, PERL_CORE)", + ovp->ov_rmagic == RMAGIC - 1 ? + "Duplicate" : "Bad"); + } +#else + warn("%s free() ignored (RMAGIC)", ovp->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad"); +#endif +#else +#ifdef PERL_CORE + { + dTHX; + if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC)) + Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s", "Bad free() ignored (PERL_CORE)"); + } #else warn("%s", "Bad free() ignored"); #endif +#endif return; /* sanity */ } #ifdef RCHECK @@ -1570,19 +1691,40 @@ Perl_realloc(void *mp, size_t nbytes) { static int bad_free_warn = -1; if (bad_free_warn == -1) { + dTHX; char *pbf = PerlEnv_getenv("PERL_BADFREE"); bad_free_warn = (pbf) ? atoi(pbf) : 1; } if (!bad_free_warn) - return; + return Nullch; #ifdef RCHECK +#ifdef PERL_CORE + { + dTHX; + if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC)) + Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%srealloc() %signored", + (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "), + ovp->ov_rmagic == RMAGIC - 1 + ? "of freed memory " : ""); + } +#else warn("%srealloc() %signored", (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "), ovp->ov_rmagic == RMAGIC - 1 ? "of freed memory " : ""); +#endif +#else +#ifdef PERL_CORE + { + dTHX; + if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC)) + Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s", + "Bad realloc() ignored"); + } #else warn("%s", "Bad realloc() ignored"); #endif - return; /* sanity */ +#endif + return Nullch; /* sanity */ } onb = BUCKET_SIZE_REAL(bucket); @@ -1654,8 +1796,8 @@ Perl_realloc(void *mp, size_t nbytes) #endif res = cp; DEBUG_m(PerlIO_printf(Perl_debug_log, - "0x%lx: (%05lu) realloc %ld bytes inplace\n", - (unsigned long)res,(unsigned long)(PL_an++), + "0x%"UVxf": (%05lu) realloc %ld bytes inplace\n", + PTR2UV(res),(unsigned long)(PL_an++), (long)size)); } else if (incr == 1 && (cp - M_OVERHEAD == last_op) && (onb > (1 << LOG_OF_MIN_ARENA))) { @@ -1690,8 +1832,8 @@ Perl_realloc(void *mp, size_t nbytes) } else { hard_way: DEBUG_m(PerlIO_printf(Perl_debug_log, - "0x%lx: (%05lu) realloc %ld bytes the hard way\n", - (unsigned long)cp,(unsigned long)(PL_an++), + "0x%"UVxf": (%05lu) realloc %ld bytes the hard way\n", + PTR2UV(cp),(unsigned long)(PL_an++), (long)size)); if ((res = (char*)Perl_malloc(nbytes)) == NULL) return (NULL); @@ -1702,28 +1844,6 @@ Perl_realloc(void *mp, size_t nbytes) return ((Malloc_t)res); } -/* - * Search ``srchlen'' elements of each free list for a block whose - * header starts at ``freep''. If srchlen is -1 search the whole list. - * Return bucket number, or -1 if not found. - */ -static int -findbucket(union overhead *freep, int srchlen) -{ - register union overhead *p; - register int i, j; - - for (i = 0; i < NBUCKETS; i++) { - j = 0; - for (p = nextf[i]; p && j != srchlen; p = p->ov_next) { - if (p == freep) - return (i); - j++; - } - } - return (-1); -} - Malloc_t Perl_calloc(register size_t elements, register size_t size) { @@ -1740,9 +1860,9 @@ char * Perl_strdup(const char *s) { MEM_SIZE l = strlen(s); - char *s1 = (char *)Perl_malloc(l); + char *s1 = (char *)Perl_malloc(l+1); - Copy(s, s1, (MEM_SIZE)l, char); + Copy(s, s1, (MEM_SIZE)(l+1), char); return s1; } @@ -1768,8 +1888,8 @@ Perl_putenv(char *a) else var = Perl_malloc(l + 1); Copy(a, var, l, char); - val++; - my_setenv(var,val); + var[l + 1] = 0; + my_setenv(var, val+1); if (var != buf) Perl_mfree(var); return 0; @@ -1799,107 +1919,134 @@ Perl_malloced_size(void *p) # else # define MIN_EVEN_REPORT MIN_BUCKET # endif -/* - * mstats - print out statistics about malloc - * - * Prints two lines of numbers, one showing the length of the free list - * for each size category, the second showing the number of mallocs - - * frees for each size category. - */ -void -Perl_dump_mstats(pTHX_ char *s) + +int +Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level) { #ifdef DEBUGGING_MSTATS register int i, j; register union overhead *p; - int topbucket=0, topbucket_ev=0, topbucket_odd=0, totfree=0, total=0; - u_int nfree[NBUCKETS]; - int total_chain = 0; struct chunk_chain_s* nextchain; + buf->topbucket = buf->topbucket_ev = buf->topbucket_odd + = buf->totfree = buf->total = buf->total_chain = 0; + + buf->minbucket = MIN_BUCKET; MALLOC_LOCK; for (i = MIN_BUCKET ; i < NBUCKETS; i++) { for (j = 0, p = nextf[i]; p; p = p->ov_next, j++) ; - nfree[i] = j; - totfree += nfree[i] * BUCKET_SIZE_REAL(i); - total += nmalloc[i] * BUCKET_SIZE_REAL(i); + if (i < buflen) { + buf->nfree[i] = j; + buf->ntotal[i] = nmalloc[i]; + } + buf->totfree += j * BUCKET_SIZE_REAL(i); + buf->total += nmalloc[i] * BUCKET_SIZE_REAL(i); if (nmalloc[i]) { - i % 2 ? (topbucket_odd = i) : (topbucket_ev = i); - topbucket = i; + i % 2 ? (buf->topbucket_odd = i) : (buf->topbucket_ev = i); + buf->topbucket = i; } } nextchain = chunk_chain; while (nextchain) { - total_chain += nextchain->size; + buf->total_chain += nextchain->size; nextchain = nextchain->next; } + buf->total_sbrk = goodsbrk + sbrk_slack; + buf->sbrks = sbrks; + buf->sbrk_good = sbrk_good; + buf->sbrk_slack = sbrk_slack; + buf->start_slack = start_slack; + buf->sbrked_remains = sbrked_remains; MALLOC_UNLOCK; + buf->nbuckets = NBUCKETS; + if (level) { + for (i = MIN_BUCKET ; i < NBUCKETS; i++) { + if (i >= buflen) + break; + buf->bucket_mem_size[i] = BUCKET_SIZE(i); + buf->bucket_available_size[i] = BUCKET_SIZE_REAL(i); + } + } +#endif /* defined DEBUGGING_MSTATS */ + return 0; /* XXX unused */ +} +/* + * mstats - print out statistics about malloc + * + * Prints two lines of numbers, one showing the length of the free list + * for each size category, the second showing the number of mallocs - + * frees for each size category. + */ +void +Perl_dump_mstats(pTHX_ char *s) +{ +#ifdef DEBUGGING_MSTATS + register int i; + perl_mstats_t buffer; + UV nf[NBUCKETS]; + UV nt[NBUCKETS]; + + buffer.nfree = nf; + buffer.ntotal = nt; + get_mstats(&buffer, NBUCKETS, 0); + if (s) - PerlIO_printf(PerlIO_stderr(), - "Memory allocation statistics %s (buckets %ld(%ld)..%ld(%ld)\n", + PerlIO_printf(Perl_error_log, + "Memory allocation statistics %s (buckets %"IVdf"(%"IVdf")..%"IVdf"(%"IVdf")\n", s, - (long)BUCKET_SIZE_REAL(MIN_BUCKET), - (long)BUCKET_SIZE(MIN_BUCKET), - (long)BUCKET_SIZE_REAL(topbucket), (long)BUCKET_SIZE(topbucket)); - PerlIO_printf(PerlIO_stderr(), "%8d free:", totfree); - for (i = MIN_EVEN_REPORT; i <= topbucket; i += BUCKETS_PER_POW2) { - PerlIO_printf(PerlIO_stderr(), + (IV)BUCKET_SIZE_REAL(MIN_BUCKET), + (IV)BUCKET_SIZE(MIN_BUCKET), + (IV)BUCKET_SIZE_REAL(buffer.topbucket), + (IV)BUCKET_SIZE(buffer.topbucket)); + PerlIO_printf(Perl_error_log, "%8"IVdf" free:", buffer.totfree); + for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) { + PerlIO_printf(Perl_error_log, ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) - ? " %5d" - : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")), - nfree[i]); + ? " %5"UVuf + : ((i < 12*BUCKETS_PER_POW2) ? " %3"UVuf : " %"UVuf)), + buffer.nfree[i]); } #ifdef BUCKETS_ROOT2 - PerlIO_printf(PerlIO_stderr(), "\n\t "); - for (i = MIN_BUCKET + 1; i <= topbucket_odd; i += BUCKETS_PER_POW2) { - PerlIO_printf(PerlIO_stderr(), + PerlIO_printf(Perl_error_log, "\n\t "); + for (i = MIN_BUCKET + 1; i <= buffer.topbucket_odd; i += BUCKETS_PER_POW2) { + PerlIO_printf(Perl_error_log, ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) - ? " %5d" - : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")), - nfree[i]); + ? " %5"UVuf + : ((i < 12*BUCKETS_PER_POW2) ? " %3"UVuf : " %"UVuf)), + buffer.nfree[i]); } #endif - PerlIO_printf(PerlIO_stderr(), "\n%8d used:", total - totfree); - for (i = MIN_EVEN_REPORT; i <= topbucket; i += BUCKETS_PER_POW2) { - PerlIO_printf(PerlIO_stderr(), + PerlIO_printf(Perl_error_log, "\n%8"IVdf" used:", buffer.total - buffer.totfree); + for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) { + PerlIO_printf(Perl_error_log, ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) - ? " %5d" - : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")), - nmalloc[i] - nfree[i]); + ? " %5"IVdf + : ((i < 12*BUCKETS_PER_POW2) ? " %3"IVdf : " %"IVdf)), + buffer.ntotal[i] - buffer.nfree[i]); } #ifdef BUCKETS_ROOT2 - PerlIO_printf(PerlIO_stderr(), "\n\t "); - for (i = MIN_BUCKET + 1; i <= topbucket_odd; i += BUCKETS_PER_POW2) { - PerlIO_printf(PerlIO_stderr(), + PerlIO_printf(Perl_error_log, "\n\t "); + for (i = MIN_BUCKET + 1; i <= buffer.topbucket_odd; i += BUCKETS_PER_POW2) { + PerlIO_printf(Perl_error_log, ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) - ? " %5d" - : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")), - nmalloc[i] - nfree[i]); + ? " %5"IVdf + : ((i < 12*BUCKETS_PER_POW2) ? " %3"IVdf : " %"IVdf)), + buffer.ntotal[i] - buffer.nfree[i]); } #endif - PerlIO_printf(PerlIO_stderr(), "\nTotal sbrk(): %d/%d:%d. Odd ends: pad+heads+chain+tail: %d+%d+%d+%d.\n", - goodsbrk + sbrk_slack, sbrks, sbrk_good, sbrk_slack, - start_slack, total_chain, sbrked_remains); + PerlIO_printf(Perl_error_log, "\nTotal sbrk(): %"IVdf"/%"IVdf":%"IVdf". Odd ends: pad+heads+chain+tail: %"IVdf"+%"IVdf"+%"IVdf"+%"IVdf".\n", + buffer.total_sbrk, buffer.sbrks, buffer.sbrk_good, + buffer.sbrk_slack, buffer.start_slack, + buffer.total_chain, buffer.sbrked_remains); #endif /* DEBUGGING_MSTATS */ } #endif /* lint */ #ifdef USE_PERL_SBRK -# if defined(__MACHTEN_PPC__) || defined(NeXT) || defined(__NeXT__) +# if defined(__MACHTEN_PPC__) || defined(NeXT) || defined(__NeXT__) || defined(PURIFY) # define PERL_SBRK_VIA_MALLOC -/* - * MachTen's malloc() returns a buffer aligned on a two-byte boundary. - * While this is adequate, it may slow down access to longer data - * types by forcing multiple memory accesses. It also causes - * complaints when RCHECK is in force. So we allocate six bytes - * more than we need to, and return an address rounded up to an - * eight-byte boundary. - * - * 980701 Dominic Dunlop - */ -# define SYSTEM_ALLOC_ALIGNMENT 2 # endif # ifdef PERL_SBRK_VIA_MALLOC @@ -1962,8 +2109,8 @@ Perl_sbrk(int size) } } - DEBUG_m(PerlIO_printf(Perl_debug_log, "sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%lx\n", - size, reqsize, Perl_sbrk_oldsize, got)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%"UVxf"\n", + size, reqsize, Perl_sbrk_oldsize, PTR2UV(got))); return (void *)got; }