X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=malloc.c;h=4f7289fa67d14a1dd07ea204b5ef8c866c965e7d;hb=453189b60dbb6e88d68de022c83a2a4ff03203fd;hp=0dc732cc7d3e2e7fe30f69d215c180d33d8e248d;hpb=76cfd9aab7f7c0e39ea86aa1b2b9572c573b7b6f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/malloc.c b/malloc.c index 0dc732c..4f7289f 100644 --- a/malloc.c +++ b/malloc.c @@ -125,6 +125,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 +146,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 +240,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 @@ -245,6 +259,9 @@ # 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 +285,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 @@ -313,11 +336,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 */ @@ -435,8 +458,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 */ @@ -822,11 +850,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 @@ -835,30 +869,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 int 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) { @@ -906,51 +976,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]; - -#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 -#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 @@ -1027,7 +1061,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); } } @@ -1037,7 +1096,7 @@ Perl_malloc(register size_t nbytes) DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05lu) malloc %ld bytes\n", - PTR2UV(p+1), (unsigned long)(PL_an++), + PTR2UV(p), (unsigned long)(PL_an++), (long)size)); /* remove from linked list */ @@ -1052,7 +1111,7 @@ Perl_malloc(register size_t nbytes) dTHX; PerlIO_printf(PerlIO_stderr(), "Unaligned `next' pointer in the free " - "chain 0x"UVxf" at 0x%"UVxf"\n", + "chain 0x%"UVxf" at 0x%"UVxf"\n", PTR2UV(p->ov_next), PTR2UV(p)); } #endif @@ -1190,14 +1249,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) @@ -1335,6 +1394,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; @@ -1343,7 +1405,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; @@ -1766,28 +1828,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) { @@ -1903,6 +1943,7 @@ Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level) 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) @@ -1925,12 +1966,10 @@ void Perl_dump_mstats(pTHX_ char *s) { #ifdef DEBUGGING_MSTATS - register int i, j; - register union overhead *p; + register int i; perl_mstats_t buffer; - unsigned long nf[NBUCKETS]; - unsigned long nt[NBUCKETS]; - struct chunk_chain_s* nextchain; + UV nf[NBUCKETS]; + UV nt[NBUCKETS]; buffer.nfree = nf; buffer.ntotal = nt; @@ -1938,18 +1977,18 @@ Perl_dump_mstats(pTHX_ char *s) if (s) PerlIO_printf(Perl_error_log, - "Memory allocation statistics %s (buckets %ld(%ld)..%ld(%ld)\n", + "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(buffer.topbucket), - (long)BUCKET_SIZE(buffer.topbucket)); - PerlIO_printf(Perl_error_log, "%8ld free:", buffer.totfree); + (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")), + ? " %5"UVuf + : ((i < 12*BUCKETS_PER_POW2) ? " %3"UVuf : " %"UVuf)), buffer.nfree[i]); } #ifdef BUCKETS_ROOT2 @@ -1957,17 +1996,17 @@ Perl_dump_mstats(pTHX_ char *s) 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")), + ? " %5"UVuf + : ((i < 12*BUCKETS_PER_POW2) ? " %3"UVuf : " %"UVuf)), buffer.nfree[i]); } #endif - PerlIO_printf(Perl_error_log, "\n%8ld used:", buffer.total - buffer.totfree); + 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")), + ? " %5"IVdf + : ((i < 12*BUCKETS_PER_POW2) ? " %3"IVdf : " %"IVdf)), buffer.ntotal[i] - buffer.nfree[i]); } #ifdef BUCKETS_ROOT2 @@ -1975,12 +2014,12 @@ Perl_dump_mstats(pTHX_ char *s) 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")), + ? " %5"IVdf + : ((i < 12*BUCKETS_PER_POW2) ? " %3"IVdf : " %"IVdf)), buffer.ntotal[i] - buffer.nfree[i]); } #endif - PerlIO_printf(Perl_error_log, "\nTotal sbrk(): %ld/%ld:%ld. Odd ends: pad+heads+chain+tail: %ld+%ld+%ld+%ld.\n", + 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); @@ -1992,17 +2031,6 @@ Perl_dump_mstats(pTHX_ char *s) # 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