X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=malloc.c;h=e6484016176bfb9452cabe33e7d10ddc1c39de05;hb=6a93df2e699ee31021f3373dcafbb41d67f7f951;hp=55da67c1bd7657bf9d7585a83e7c7d6780f0dbd5;hpb=00ff3b56132a225d6f20f8216aaa1d9a45a711a2;p=p5sagit%2Fp5-mst-13.2.git diff --git a/malloc.c b/malloc.c index 55da67c..e648401 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.) @@ -255,7 +259,6 @@ # include # include # include -# define _(arg) arg # ifndef Malloc_t # define Malloc_t void * # endif @@ -291,7 +294,7 @@ # ifndef warn # define warn(mess, arg) fprintf(stderr, (mess), (arg)) # endif -# ifndef warn +# ifndef warn2 # define warn2(mess, arg1) fprintf(stderr, (mess), (arg1), (arg2)) # endif # ifdef DEBUG_m @@ -304,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 @@ -349,9 +356,16 @@ #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 @@ -860,11 +874,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 @@ -890,16 +900,12 @@ static union overhead *nextf[NBUCKETS]; #endif #ifdef USE_PERL_SBRK -#define sbrk(a) Perl_sbrk(a) +# define sbrk(a) Perl_sbrk(a) Malloc_t Perl_sbrk (int size); -#else -#ifdef DONT_DECLARE_STD -#ifdef I_UNISTD -#include -#endif #else +# ifndef HAS_SBRK_PROTO /* usually takes care of this */ extern Malloc_t sbrk(int); -#endif +# endif #endif #ifdef DEBUGGING_MSTATS @@ -916,9 +922,15 @@ static u_int start_slack; 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. +static MEM_SIZE no_mem; /* 0 if the last request for more memory succeeded. Otherwise the size of the failing request. */ static Malloc_t @@ -983,9 +995,10 @@ emergency_sbrk(MEM_SIZE size) 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)) */ +# endif +#endif /* ifdef PERL_CORE */ #ifdef DEBUGGING #undef ASSERT @@ -1042,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) */ @@ -1062,6 +1077,9 @@ Perl_malloc(register size_t nbytes) { dTHX; if (!PL_nomemok) { +#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; @@ -1084,6 +1102,7 @@ Perl_malloc(register size_t nbytes) } 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); } } @@ -1091,11 +1110,6 @@ Perl_malloc(register size_t nbytes) return (NULL); } - DEBUG_m(PerlIO_printf(Perl_debug_log, - "0x%"UVxf": (%05lu) malloc %ld bytes\n", - PTR2UV(p+1), (unsigned long)(PL_an++), - (long)size)); - /* remove from linked list */ #if defined(RCHECK) if ((PTR2UV(p)) & (MEM_ALIGNBYTES - 1)) { @@ -1116,6 +1130,11 @@ Perl_malloc(register size_t nbytes) MALLOC_UNLOCK; + DEBUG_m(PerlIO_printf(Perl_debug_log, + "0x%"UVxf": (%05lu) malloc %ld bytes\n", + PTR2UV((Malloc_t)(p + CHUNK_SHIFT)), (unsigned long)(PL_an++), + (long)size)); + #ifdef IGNORE_SMALL_BAD_FREE if (bucket >= FIRST_BUCKET_WITH_CHECK) #endif @@ -1148,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 @@ -1391,7 +1410,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; @@ -1581,12 +1602,12 @@ Perl_mfree(void *mp) { dTHX; if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC)) - Perl_warner(aTHX_ WARN_MALLOC, "%s free() ignored", + Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s free() ignored (RMAGIC, PERL_CORE)", ovp->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad"); } #else - warn("%s free() ignored", + warn("%s free() ignored (RMAGIC)", ovp->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad"); #endif #else @@ -1594,7 +1615,7 @@ Perl_mfree(void *mp) { dTHX; if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC)) - Perl_warner(aTHX_ WARN_MALLOC, "%s", "Bad free() ignored"); + Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s", "Bad free() ignored (PERL_CORE)"); } #else warn("%s", "Bad free() ignored"); @@ -1681,7 +1702,7 @@ Perl_realloc(void *mp, size_t nbytes) { dTHX; if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC)) - Perl_warner(aTHX_ WARN_MALLOC, "%srealloc() %signored", + Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%srealloc() %signored", (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "), ovp->ov_rmagic == RMAGIC - 1 ? "of freed memory " : ""); @@ -1696,7 +1717,7 @@ Perl_realloc(void *mp, size_t nbytes) { dTHX; if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC)) - Perl_warner(aTHX_ WARN_MALLOC, "%s", + Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s", "Bad realloc() ignored"); } #else