X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=malloc.c;h=f73e22dfd433cd0b632f57edc89d4f652f364d4c;hb=61d42ce43847d6cea183d4f40e2921e53606f13f;hp=7584000e3408680ffbf4acd319a700e80a2319d6;hpb=22d4bb9ccb8701e68f9243547d7e3a3c55f70908;p=p5sagit%2Fp5-mst-13.2.git diff --git a/malloc.c b/malloc.c index 7584000..f73e22d 100644 --- a/malloc.c +++ b/malloc.c @@ -146,9 +146,15 @@ # 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(&PL_malloc_mutex) MALLOC_UNLOCK MUTEX_UNLOCK(&PL_malloc_mutex) @@ -234,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 @@ -274,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 @@ -287,7 +304,11 @@ # ifndef pTHX # define pTHX void # define pTHX_ -# define dTHX extern int Perl___notused +# ifdef HASATTRIBUTE +# define dTHX extern int Perl___notused __attribute__ ((unused)) +# else +# define dTHX extern int Perl___notused +# endif # define WITH_THX(s) s # endif # ifndef PERL_GET_INTERP @@ -334,7 +355,7 @@ # undef DEBUG_m # 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) { a; } } \ } STMT_END #endif @@ -441,6 +462,11 @@ union overhead { double strut; /* alignment problems */ #endif struct { +/* + * 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 @@ -838,11 +864,7 @@ 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); -#if defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE) - -# ifndef BIG_SIZE -# define BIG_SIZE (1<<16) /* 64K */ -# endif +#ifdef PERL_CORE #ifdef I_MACH_CTHREADS # undef MUTEX_LOCK @@ -851,18 +873,66 @@ static int getpages_adjacent(MEM_SIZE require); # define MUTEX_UNLOCK(m) STMT_START { if (*m) mutex_unlock(*m); } STMT_END #endif +#ifndef BITS_IN_PTR +# define BITS_IN_PTR (8*PTRSIZE) +#endif + +/* + * 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 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) { @@ -910,55 +980,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)) */ - -#ifndef BITS_IN_PTR -# define BITS_IN_PTR (8*PTRSIZE) -#endif - -/* - * 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 -#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 @@ -1015,7 +1045,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) */ @@ -1035,7 +1067,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); } } @@ -1045,7 +1102,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 */ @@ -1343,6 +1400,9 @@ getpages(MEM_SIZE 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;