X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/b022d2d27f9b150bfa61c150f89ab4147aeb4595..8e0c32f43cbc5d9f577b2602ba2159b9cd123197:/malloc.c diff --git a/malloc.c b/malloc.c index fc37cb2..53835e1 100644 --- a/malloc.c +++ b/malloc.c @@ -3,9 +3,20 @@ */ /* - Here are some notes on configuring Perl's malloc. (For non-perl - usage see below.) - + * 'The Chamber of Records,' said Gimli. 'I guess that is where we now stand.' + * + * [p.321 of _The Lord of the Rings_, II/v: "The Bridge of Khazad-Dûm"] + */ + +/* This file contains Perl's own implementation of the malloc library. + * It is used if Configure decides that, on your platform, Perl's + * version is better than the OS's, or if you give Configure the + * -Dusemymalloc command-line option. + */ + +/* + Here are some notes on configuring Perl's malloc. + There are two macros which serve as bulk disablers of advanced features of this malloc: NO_FANCY_MALLOC, PLAIN_MALLOC (undef by default). Look in the list of default values below to understand @@ -23,12 +34,15 @@ options take a precise value, while the others are just boolean. The boolean ones are listed first. + # Read configuration settings from malloc_cfg.h + HAVE_MALLOC_CFG_H undef + # Enable code for an emergency memory pool in $^M. See perlvar.pod # for a description of $^M. - PERL_EMERGENCY_SBRK (!PLAIN_MALLOC && PERL_CORE) + PERL_EMERGENCY_SBRK !PLAIN_MALLOC # Enable code for printing memory statistics. - DEBUGGING_MSTATS (!PLAIN_MALLOC && PERL_CORE) + DEBUGGING_MSTATS !PLAIN_MALLOC # Move allocation info for small buckets into separate areas. # Memory optimization (especially for small allocations, of the @@ -74,6 +88,22 @@ # pessimization, error reporting optimization RCHECK (DEBUGGING && !NO_RCHECK) + # Do not overwrite uninit areas with DEBUGGING. Speed + # optimization, error reporting pessimization + NO_MFILL undef + + # Overwrite uninit areas with DEBUGGING. Speed + # pessimization, error reporting optimization + MALLOC_FILL (DEBUGGING && !NO_RCHECK && !NO_MFILL) + + # Do not check overwritten uninit areas with DEBUGGING. Speed + # optimization, error reporting pessimization + NO_FILL_CHECK undef + + # Check overwritten uninit areas with DEBUGGING. Speed + # pessimization, error reporting optimization + MALLOC_FILL_CHECK (DEBUGGING && !NO_RCHECK && !NO_FILL_CHECK) + # Failed allocations bigger than this size croak (if # PERL_EMERGENCY_SBRK is enabled) without touching $^M. See # perlvar.pod for a description of $^M. @@ -94,6 +124,9 @@ # Round up sbrk()s to multiples of this percent of footprint. MIN_SBRK_FRAC 3 + # Round up sbrk()s to multiples of this multiple of 1/1000 of footprint. + MIN_SBRK_FRAC1000 (10 * MIN_SBRK_FRAC) + # Add this much memory to big powers of two to get the bucket size. PERL_PAGESIZE 4096 @@ -110,59 +143,29 @@ # define this to disable 12-byte bucket (will increase memory footprint) STRICT_ALIGNMENT undef - This implementation assumes that calling PerlIO_printf() does not - result in any memory allocation calls (used during a panic). - - */ - -/* - If used outside of Perl environment, it may be useful to redefine - the following macros (listed below with defaults): - - # Type of address returned by allocation functions - Malloc_t void * - - # Type of size argument for allocation functions - MEM_SIZE unsigned long - - # size of void* - PTRSIZE 4 - - # Maximal value in LONG - LONG_MAX 0x7FFFFFFF - - # Unsigned integer type big enough to keep a pointer - UV unsigned long + # Do not allow configuration of runtime options at runtime + NO_MALLOC_DYNAMIC_CFG undef - # Type of pointer with 1-byte granularity - caddr_t char * + # Do not allow configuration of runtime options via $ENV{PERL_MALLOC_OPT} + NO_PERL_MALLOC_ENV undef - # Type returned by free() - Free_t void + [The variable consists of ;-separated parts of the form CODE=VALUE + with 1-character codes F, M, f, A, P, G, d, a, c for runtime + configuration of FIRST_SBRK, MIN_SBRK, MIN_SBRK_FRAC1000, + SBRK_ALLOW_FAILURES, SBRK_FAILURE_PRICE, sbrk_goodness, + filldead, fillalive, fillcheck. The last 3 are for DEBUGGING + build, and allow switching the tests for free()ed memory read, + uninit memory reads, and free()ed memory write.] - # Very fatal condition reporting function (cannot call any ) - fatalcroak(arg) write(2,arg,strlen(arg)) + exit(2) - - # 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) + This implementation assumes that calling PerlIO_printf() does not + result in any memory allocation calls (used during a panic). - # 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) - # Locking/unlocking mutex for MT operation - MUTEX_LOCK(l) void - MUTEX_UNLOCK(l) void - */ +#ifdef HAVE_MALLOC_CFG_H +# include "malloc_cfg.h" +#endif #ifndef NO_FANCY_MALLOC # ifndef SMALL_BUCKET_VIA_TABLE @@ -183,10 +186,10 @@ # ifndef TWO_POT_OPTIMIZE # define TWO_POT_OPTIMIZE # endif -# if defined(PERL_CORE) && !defined(PERL_EMERGENCY_SBRK) +# ifndef PERL_EMERGENCY_SBRK # define PERL_EMERGENCY_SBRK # endif -# if defined(PERL_CORE) && !defined(DEBUGGING_MSTATS) +# ifndef DEBUGGING_MSTATS # define DEBUGGING_MSTATS # endif #endif @@ -194,22 +197,20 @@ #define MIN_BUC_POW2 (sizeof(void*) > 4 ? 3 : 2) /* Allow for 4-byte arena. */ #define MIN_BUCKET (MIN_BUC_POW2 * BUCKETS_PER_POW2) -#if !(defined(I286) || defined(atarist) || defined(__MINT__)) - /* take 2k unless the block is bigger than that */ -# define LOG_OF_MIN_ARENA 11 -#else - /* take 16k unless the block is bigger than that - (80286s like large segments!), probably good on the atari too */ -# define LOG_OF_MIN_ARENA 14 -#endif +#define LOG_OF_MIN_ARENA 11 -#ifndef lint -# if defined(DEBUGGING) && !defined(NO_RCHECK) -# define RCHECK -# endif -# if defined(RCHECK) && defined(IGNORE_SMALL_BAD_FREE) -# undef IGNORE_SMALL_BAD_FREE -# endif +#if defined(DEBUGGING) && !defined(NO_RCHECK) +# define RCHECK +#endif +#if defined(DEBUGGING) && !defined(NO_RCHECK) && !defined(NO_MFILL) && !defined(MALLOC_FILL) +# define MALLOC_FILL +#endif +#if defined(DEBUGGING) && !defined(NO_RCHECK) && !defined(NO_FILL_CHECK) && !defined(MALLOC_FILL_CHECK) +# define MALLOC_FILL_CHECK +#endif +#if defined(RCHECK) && defined(IGNORE_SMALL_BAD_FREE) +# undef IGNORE_SMALL_BAD_FREE +#endif /* * malloc.c (Caltech) 2/21/82 * Chris Kingsley, kingsley@cit-20. @@ -228,103 +229,32 @@ * than it was, and takes 67% of old heap size for typical usage.) * * Allocations of small blocks are now table-driven to many different - * buckets. Sizes of really big buckets are increased to accomodata + * buckets. Sizes of really big buckets are increased to accommodate * common size=power-of-2 blocks. Running-out-of-memory is made into * an exception. Deeply configurable and thread-safe. * */ -#ifdef PERL_CORE -# include "EXTERN.h" -# define PERL_IN_MALLOC_C -# include "perl.h" -# if defined(PERL_IMPLICIT_CONTEXT) +#include "EXTERN.h" +#define PERL_IN_MALLOC_C +#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 +#else # define croak2 croak # define warn2 warn -# endif +#endif +#ifdef USE_ITHREADS +# define PERL_MAYBE_ALIVE PL_thr_key #else -# ifdef PERL_FOR_X2P -# include "../EXTERN.h" -# include "../perl.h" -# else -# 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 -# ifndef LONG_MAX -# define LONG_MAX 0x7FFFFFFF -# endif -# ifndef UV -# define UV unsigned long -# endif -# ifndef caddr_t -# define caddr_t char * -# endif -# ifndef Free_t -# define Free_t void -# endif -# define Copy(s,d,n,t) (void)memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) -# define PerlEnv_getenv getenv -# define PerlIO_printf fprintf -# define PerlIO_stderr() stderr -# endif -# 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 warn -# define warn2(mess, arg1) fprintf(stderr, (mess), (arg1), (arg2)) -# endif -# ifdef DEBUG_m -# undef DEBUG_m -# endif -# define DEBUG_m(a) -# ifdef DEBUGGING -# undef DEBUGGING -# endif -# ifndef pTHX -# define pTHX void -# define pTHX_ -# define dTHX extern int Perl___notused -# define WITH_THX(s) s -# endif -# ifndef PERL_GET_INTERP -# define PERL_GET_INTERP PL_curinterp -# endif -# ifndef Perl_malloc -# define Perl_malloc malloc -# endif -# ifndef Perl_mfree -# define Perl_mfree free -# endif -# ifndef Perl_realloc -# define Perl_realloc realloc -# endif -# ifndef Perl_calloc -# define Perl_calloc calloc -# endif -# ifndef Perl_strdup -# define Perl_strdup strdup -# endif +# define PERL_MAYBE_ALIVE 1 +#endif + +#ifndef MYMALLOC +# error "MYMALLOC is not defined" #endif #ifndef MUTEX_LOCK @@ -349,9 +279,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_MAYBE_ALIVE && PERL_GET_THX) { \ + dTHX; \ + if (DEBUG_m_TEST) { \ + PL_debug &= ~DEBUG_m_FLAG; \ + a; \ + PL_debug |= DEBUG_m_FLAG; \ + } \ + } \ } STMT_END #endif @@ -436,8 +373,7 @@ */ #define u_short unsigned short -/* 286 and atarist like big chunks, which gives too much overhead. */ -#if (defined(RCHECK) || defined(I286) || defined(atarist) || defined(__MINT__)) && defined(PACK_MALLOC) +#if defined(RCHECK) && defined(PACK_MALLOC) # undef PACK_MALLOC #endif @@ -456,12 +392,21 @@ union overhead { union overhead *ov_next; /* when free */ #if MEM_ALIGNBYTES > 4 double strut; /* alignment problems */ +# if MEM_ALIGNBYTES > 8 + char sstrut[MEM_ALIGNBYTES]; /* for the sizing */ +# endif #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 - u_short ovu_size; /* actual block size */ + /* Subtract one to fit into u_short for an extra bucket */ + u_short ovu_size; /* block size (requested + overhead - 1) */ u_int ovu_rmagic; /* range magic number */ #endif } ovu; @@ -476,14 +421,14 @@ union overhead { #define RMAGIC_C 0x55 /* magic # on range info */ #ifdef RCHECK -# define RSLOP sizeof (u_int) +# define RMAGIC_SZ sizeof (u_int) /* Overhead at end of bucket */ # ifdef TWO_POT_OPTIMIZE -# define MAX_SHORT_BUCKET (12 * BUCKETS_PER_POW2) +# define MAX_SHORT_BUCKET (12 * BUCKETS_PER_POW2) /* size-1 fits in short */ # else # define MAX_SHORT_BUCKET (13 * BUCKETS_PER_POW2) # endif #else -# define RSLOP 0 +# define RMAGIC_SZ 0 #endif #if !defined(PACK_MALLOC) && defined(BUCKETS_ROOT2) @@ -506,7 +451,7 @@ struct aligner { char c; void *p; }; -# define ALIGN_SMALL ((int)((caddr_t)&(((struct aligner*)0)->p))) +# define ALIGN_SMALL ((IV)((caddr_t)&(((struct aligner*)0)->p))) #else # define ALIGN_SMALL MEM_ALIGNBYTES #endif @@ -515,19 +460,20 @@ struct aligner { #ifdef BUCKETS_ROOT2 # define MAX_BUCKET_BY_TABLE 13 -static u_short buck_size[MAX_BUCKET_BY_TABLE + 1] = +static const u_short buck_size[MAX_BUCKET_BY_TABLE + 1] = { 0, 0, 0, 0, 4, 4, 8, 12, 16, 24, 32, 48, 64, 80, }; -# define BUCKET_SIZE(i) ((i) % 2 ? buck_size[i] : (1 << ((i) >> BUCKET_POW2_SHIFT))) +# define BUCKET_SIZE_NO_SURPLUS(i) ((i) % 2 ? buck_size[i] : (1 << ((i) >> BUCKET_POW2_SHIFT))) # define BUCKET_SIZE_REAL(i) ((i) <= MAX_BUCKET_BY_TABLE \ - ? buck_size[i] \ - : ((1 << ((i) >> BUCKET_POW2_SHIFT)) \ + ? ((size_t)buck_size[i]) \ + : ((((size_t)1) << ((i) >> BUCKET_POW2_SHIFT)) \ - MEM_OVERHEAD(i) \ + POW2_OPTIMIZE_SURPLUS(i))) #else -# define BUCKET_SIZE(i) (1 << ((i) >> BUCKET_POW2_SHIFT)) -# define BUCKET_SIZE_REAL(i) (BUCKET_SIZE(i) - MEM_OVERHEAD(i) + POW2_OPTIMIZE_SURPLUS(i)) +# define BUCKET_SIZE_NO_SURPLUS(i) (((size_t)1) << ((i) >> BUCKET_POW2_SHIFT)) +# define BUCKET_SIZE(i) (BUCKET_SIZE_NO_SURPLUS(i) + POW2_OPTIMIZE_SURPLUS(i)) +# define BUCKET_SIZE_REAL(i) (BUCKET_SIZE(i) - MEM_OVERHEAD(i)) #endif @@ -564,7 +510,7 @@ static u_short buck_size[MAX_BUCKET_BY_TABLE + 1] = * encodes the size of the chunk, while MAGICn encodes state (used, * free or non-managed-by-us-so-it-indicates-a-bug) of CHUNKn. MAGIC * is used for sanity checking purposes only. SOMETHING is 0 or 4K - * (to make size of big CHUNK accomodate allocations for powers of two + * (to make size of big CHUNK accommodate allocations for powers of two * better). * * [There is no need to alignment between chunks, since C rules ensure @@ -672,13 +618,13 @@ static u_short buck_size[MAX_BUCKET_BY_TABLE + 1] = #ifdef IGNORE_SMALL_BAD_FREE #define FIRST_BUCKET_WITH_CHECK (6 * BUCKETS_PER_POW2) /* 64 */ # define N_BLKS(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK \ - ? ((1<= FIRST_BIG_BOUND) ? nbytes -= PERL_PAGESIZE : 0) # define POW2_OPTIMIZE_SURPLUS(bucket) \ - ((bucket >= FIRST_BIG_POW2 * BUCKETS_PER_POW2) ? PERL_PAGESIZE : 0) + ((size_t)((bucket >= FIRST_BIG_POW2 * BUCKETS_PER_POW2) ? PERL_PAGESIZE : 0)) #else /* !TWO_POT_OPTIMIZE */ # define POW2_OPTIMIZE_ADJUST(nbytes) -# define POW2_OPTIMIZE_SURPLUS(bucket) 0 +# define POW2_OPTIMIZE_SURPLUS(bucket) ((size_t)0) #endif /* !TWO_POT_OPTIMIZE */ -#if defined(HAS_64K_LIMIT) && defined(PERL_CORE) -# define BARK_64K_LIMIT(what,nbytes,size) \ - if (nbytes > 0xffff) { \ - PerlIO_printf(PerlIO_stderr(), \ - "%s too large: %lx\n", what, size); \ - my_exit(1); \ - } -#else /* !HAS_64K_LIMIT || !PERL_CORE */ -# define BARK_64K_LIMIT(what,nbytes,size) -#endif /* !HAS_64K_LIMIT || !PERL_CORE */ +#define BARK_64K_LIMIT(what,nbytes,size) #ifndef MIN_SBRK # define MIN_SBRK 2048 @@ -845,9 +782,9 @@ static char bucket_of[] = # define SBRK_FAILURE_PRICE 50 #endif -static void morecore (register int bucket); +static void morecore (int bucket); # if defined(DEBUGGING) -static void botch (char *diag, char *s); +static void botch (const char *diag, const char *s, const char *file, int line); # endif static void add_to_chain (void *p, MEM_SIZE size, MEM_SIZE chip); static void* get_from_chain (MEM_SIZE size); @@ -855,12 +792,6 @@ 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 I_MACH_CTHREADS # undef MUTEX_LOCK # define MUTEX_LOCK(m) STMT_START { if (*m) mutex_lock(*m); } STMT_END @@ -868,6 +799,10 @@ static int getpages_adjacent(MEM_SIZE require); # define MUTEX_UNLOCK(m) STMT_START { if (*m) mutex_unlock(*m); } STMT_END #endif +#ifndef PTRSIZE +# define PTRSIZE sizeof(void*) +#endif + #ifndef BITS_IN_PTR # define BITS_IN_PTR (8*PTRSIZE) #endif @@ -885,16 +820,89 @@ 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 +#elif !defined(HAS_SBRK_PROTO) /* usually takes care of this */ extern Malloc_t sbrk(int); #endif + +#ifndef MIN_SBRK_FRAC1000 /* Backward compatibility */ +# define MIN_SBRK_FRAC1000 (MIN_SBRK_FRAC * 10) +#endif + +#include "malloc_ctl.h" + +#ifndef NO_MALLOC_DYNAMIC_CFG +# define PERL_MALLOC_OPT_CHARS "FMfAPGdac" + +# ifndef FILL_DEAD_DEFAULT +# define FILL_DEAD_DEFAULT 1 +# endif +# ifndef FILL_ALIVE_DEFAULT +# define FILL_ALIVE_DEFAULT 1 +# endif +# ifndef FILL_CHECK_DEFAULT +# define FILL_CHECK_DEFAULT 1 +# endif + +static IV MallocCfg[MallocCfg_last] = { + FIRST_SBRK, + MIN_SBRK, + MIN_SBRK_FRAC, + SBRK_ALLOW_FAILURES, + SBRK_FAILURE_PRICE, + SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE, /* sbrk_goodness */ + FILL_DEAD_DEFAULT, /* FILL_DEAD */ + FILL_ALIVE_DEFAULT, /* FILL_ALIVE */ + FILL_CHECK_DEFAULT, /* FILL_CHECK */ + 0, /* MallocCfg_skip_cfg_env */ + 0, /* MallocCfg_cfg_env_read */ + 0, /* MallocCfg_emergency_buffer_size */ + 0, /* MallocCfg_emergency_buffer_prepared_size */ + 0 /* MallocCfg_emergency_buffer_last_req */ +}; +IV *MallocCfg_ptr = MallocCfg; + +static char* MallocCfgP[MallocCfg_last] = { + 0, /* MallocCfgP_emergency_buffer */ + 0, /* MallocCfgP_emergency_buffer_prepared */ +}; +char **MallocCfgP_ptr = MallocCfgP; + +# undef MIN_SBRK +# undef FIRST_SBRK +# undef MIN_SBRK_FRAC1000 +# undef SBRK_ALLOW_FAILURES +# undef SBRK_FAILURE_PRICE + +# define MIN_SBRK MallocCfg[MallocCfg_MIN_SBRK] +# define FIRST_SBRK MallocCfg[MallocCfg_FIRST_SBRK] +# define MIN_SBRK_FRAC1000 MallocCfg[MallocCfg_MIN_SBRK_FRAC1000] +# define SBRK_ALLOW_FAILURES MallocCfg[MallocCfg_SBRK_ALLOW_FAILURES] +# define SBRK_FAILURE_PRICE MallocCfg[MallocCfg_SBRK_FAILURE_PRICE] + +# define sbrk_goodness MallocCfg[MallocCfg_sbrk_goodness] + +# define emergency_buffer_size MallocCfg[MallocCfg_emergency_buffer_size] +# define emergency_buffer_last_req MallocCfg[MallocCfg_emergency_buffer_last_req] + +# define FILL_DEAD MallocCfg[MallocCfg_filldead] +# define FILL_ALIVE MallocCfg[MallocCfg_fillalive] +# define FILL_CHECK_CFG MallocCfg[MallocCfg_fillcheck] +# define FILL_CHECK (FILL_DEAD && FILL_CHECK_CFG) + +# define emergency_buffer MallocCfgP[MallocCfgP_emergency_buffer] +# define emergency_buffer_prepared MallocCfgP[MallocCfgP_emergency_buffer_prepared] + +#else /* defined(NO_MALLOC_DYNAMIC_CFG) */ + +# define FILL_DEAD 1 +# define FILL_ALIVE 1 +# define FILL_CHECK 1 +static int sbrk_goodness = SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE; + +# define NO_PERL_MALLOC_ENV + #endif #ifdef DEBUGGING_MSTATS @@ -911,108 +919,273 @@ static u_int start_slack; static u_int goodsbrk; -static char *emergency_buffer; +#ifdef PERL_EMERGENCY_SBRK + +# ifndef BIG_SIZE +# define BIG_SIZE (1<<16) /* 64K */ +# endif + +# ifdef NO_MALLOC_DYNAMIC_CFG 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. */ + /* 0 if the last request for more memory succeeded. + Otherwise the size of the failing request. */ +static MEM_SIZE emergency_buffer_last_req; +static char *emergency_buffer; +static char *emergency_buffer_prepared; +# endif + +# ifndef emergency_sbrk_croak +# define emergency_sbrk_croak croak2 +# endif + +static char * +perl_get_emergency_buffer(IV *size) +{ + dTHX; + /* First offense, give a possibility to recover by dieing. */ + /* No malloc involved here: */ + SV *sv; + char *pv; + GV **gvp = (GV**)hv_fetchs(PL_defstash, "^M", FALSE); + + if (!gvp) gvp = (GV**)hv_fetchs(PL_defstash, "\015", FALSE); + if (!gvp || !(sv = GvSV(*gvp)) || !SvPOK(sv) + || (SvLEN(sv) < (1<>LOG_OF_MIN_ARENA) + 1)<= BIG_SIZE && (!no_mem || (size < no_mem))) { + if (size >= BIG_SIZE + && (!emergency_buffer_last_req || + (size < (MEM_SIZE)emergency_buffer_last_req))) { /* Give the possibility to recover, but avoid an infinite cycle. */ MALLOC_UNLOCK; - no_mem = size; - croak2("Out of memory during \"large\" request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack)); + emergency_buffer_last_req = size; + emergency_sbrk_croak("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) { + if ((MEM_SIZE)emergency_buffer_size >= rsize) { char *old = emergency_buffer; emergency_buffer_size -= rsize; emergency_buffer += rsize; return old; } else { - dTHX; /* First offense, give a possibility to recover by dieing. */ /* No malloc involved here: */ - GV **gvp = (GV**)hv_fetch(PL_defstash, "^M", 2, 0); - SV *sv; - char *pv; + IV Size; + char *pv = GET_EMERGENCY_BUFFER(&Size); int have = 0; - STRLEN n_a; if (emergency_buffer_size) { add_to_chain(emergency_buffer, emergency_buffer_size, 0); emergency_buffer_size = 0; - emergency_buffer = Nullch; + emergency_buffer = NULL; have = 1; } - if (!gvp) gvp = (GV**)hv_fetch(PL_defstash, "\015", 1, 0); - if (!gvp || !(sv = GvSV(*gvp)) || !SvPOK(sv) - || (SvLEN(sv) < (1<> START_SHIFT; bucket = START_SHIFTS_BUCKET; /* apart from this loop, this is O(1) */ while (shiftr >>= 1) bucket += BUCKETS_PER_POW2; } + *nbytes_p = nbytes; + return bucket; +} + +Malloc_t +Perl_malloc(size_t nbytes) +{ + dVAR; + union overhead *p; + int bucket; + +#if defined(DEBUGGING) || defined(RCHECK) + MEM_SIZE size = nbytes; +#endif + + BARK_64K_LIMIT("Allocation",nbytes,nbytes); +#ifdef DEBUGGING + if ((long)nbytes < 0) + croak("%s", "panic: malloc"); +#endif + + bucket = adjust_size_and_find_bucket(&nbytes); MALLOC_LOCK; /* * If nothing in hash bucket right now, @@ -1053,16 +1250,18 @@ Perl_malloc(register size_t nbytes) morecore(bucket); if ((p = nextf[bucket]) == NULL) { MALLOC_UNLOCK; -#ifdef PERL_CORE { dTHX; if (!PL_nomemok) { +#if defined(PLAIN_MALLOC) && defined(NO_FANCY_MALLOC) + MYMALLOC_WRITE2STDERR("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 "); + MYMALLOC_WRITE2STDERR("Out of memory during request for "); #if defined(DEBUGGING) || defined(RCHECK) n = size; #endif @@ -1070,40 +1269,38 @@ Perl_malloc(register size_t nbytes) do { *--s = '0' + (n % 10); } while (n /= 10); - PerlIO_puts(PerlIO_stderr(),s); - PerlIO_puts(PerlIO_stderr()," bytes, total sbrk() is "); + MYMALLOC_WRITE2STDERR(s); + MYMALLOC_WRITE2STDERR(" 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"); + MYMALLOC_WRITE2STDERR(s); + MYMALLOC_WRITE2STDERR(" bytes!\n"); +#endif /* defined(PLAIN_MALLOC) && defined(NO_FANCY_MALLOC) */ my_exit(1); } } -#endif 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)) { +#ifdef DEBUGGING + if ( (PTR2UV(p) & (MEM_ALIGNBYTES - 1)) + /* Can't get this low */ + || (p && PTR2UV(p) < (1<ov_next)) & (MEM_ALIGNBYTES - 1)) { + if ( (PTR2UV(p->ov_next) & (MEM_ALIGNBYTES - 1)) + || (p->ov_next && PTR2UV(p->ov_next) < (1<ov_next), PTR2UV(p)); } #endif @@ -1111,6 +1308,14 @@ 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)); + + FILLCHECK_DEADBEEF((unsigned char*)(p + CHUNK_SHIFT), + BUCKET_SIZE_REAL(bucket) + RMAGIC_SZ); + #ifdef IGNORE_SMALL_BAD_FREE if (bucket >= FIRST_BUCKET_WITH_CHECK) #endif @@ -1129,22 +1334,23 @@ Perl_malloc(register size_t nbytes) nbytes = size + M_OVERHEAD; p->ov_size = nbytes - 1; - if ((i = nbytes & 3)) { - i = 4 - i; - while (i--) - *((char *)((caddr_t)p + nbytes - RSLOP + i)) = RMAGIC_C; + if ((i = nbytes & (RMAGIC_SZ-1))) { + i = RMAGIC_SZ - i; + while (i--) /* nbytes - RMAGIC_SZ is end of alloced area */ + ((caddr_t)p + nbytes - RMAGIC_SZ)[i] = RMAGIC_C; } - nbytes = (nbytes + 3) &~ 3; - *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC; + /* Same at RMAGIC_SZ-aligned RMAGIC */ + nbytes = (nbytes + RMAGIC_SZ - 1) & ~(RMAGIC_SZ - 1); + ((u_int *)((caddr_t)p + nbytes))[-1] = RMAGIC; } + FILL_FEEDADAD((unsigned char *)(p + CHUNK_SHIFT), size); #endif return ((Malloc_t)(p + CHUNK_SHIFT)); } static char *last_sbrk_top; static char *last_op; /* This arena can be easily extended. */ -static int sbrked_remains; -static int sbrk_good = SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE; +static MEM_SIZE sbrked_remains; #ifdef DEBUGGING_MSTATS static int sbrks; @@ -1230,7 +1436,7 @@ get_from_bigger_buckets(int bucket, MEM_SIZE size) nmalloc[bucket]--; start_slack -= M_OVERHEAD; #endif - add_to_chain(ret, (BUCKET_SIZE(bucket) + + add_to_chain(ret, (BUCKET_SIZE_NO_SURPLUS(bucket) + POW2_OPTIMIZE_SURPLUS(bucket)), size); return ret; @@ -1243,6 +1449,7 @@ get_from_bigger_buckets(int bucket, MEM_SIZE size) static union overhead * getpages(MEM_SIZE needed, int *nblksp, int bucket) { + dVAR; /* Need to do (possibly expensive) system call. Try to optimize it for rare calling. */ MEM_SIZE require = needed - sbrked_remains; @@ -1250,13 +1457,13 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) union overhead *ovp; MEM_SIZE slack = 0; - if (sbrk_good > 0) { - if (!last_sbrk_top && require < FIRST_SBRK) + if (sbrk_goodness > 0) { + if (!last_sbrk_top && require < (MEM_SIZE)FIRST_SBRK) require = FIRST_SBRK; - else if (require < MIN_SBRK) require = MIN_SBRK; + else if (require < (MEM_SIZE)MIN_SBRK) require = MIN_SBRK; - if (require < goodsbrk * MIN_SBRK_FRAC / 100) - require = goodsbrk * MIN_SBRK_FRAC / 100; + if (require < (Size_t)(goodsbrk * MIN_SBRK_FRAC1000 / 1000)) + require = goodsbrk * MIN_SBRK_FRAC1000 / 1000; require = ((require - 1 + MIN_SBRK) / MIN_SBRK) * MIN_SBRK; } else { require = needed; @@ -1273,7 +1480,7 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) #endif if (cp == last_sbrk_top) { /* Common case, anything is fine. */ - sbrk_good++; + sbrk_goodness++; ovp = (union overhead *) (cp - sbrked_remains); last_op = cp - sbrked_remains; sbrked_remains = require - (needed - sbrked_remains); @@ -1298,20 +1505,16 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) /* Second, check alignment. */ slack = 0; -#if !defined(atarist) && !defined(__MINT__) /* on the atari we dont have to worry about this */ -# ifndef I286 /* The sbrk(0) call on the I286 always returns the next segment */ /* WANTED_ALIGNMENT may be more than NEEDED_ALIGNMENT, but this may improve performance of memory access. */ if (PTR2UV(cp) & (WANTED_ALIGNMENT - 1)) { /* Not aligned. */ slack = WANTED_ALIGNMENT - (PTR2UV(cp) & (WANTED_ALIGNMENT - 1)); add += slack; } -# endif -#endif /* !atarist && !MINT */ if (add) { DEBUG_m(PerlIO_printf(Perl_debug_log, - "sbrk(%ld) to fix non-continuous/off-page sbrk:\n\t%ld for alignement,\t%ld were assumed to come from the tail of the previous sbrk\n", + "sbrk(%ld) to fix non-continuous/off-page sbrk:\n\t%ld for alignment,\t%ld were assumed to come from the tail of the previous sbrk\n", (long)add, (long) slack, (long) sbrked_remains)); newcp = (char *)sbrk(add); @@ -1345,7 +1548,7 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) if (cp == (char *)-1) return 0; } - sbrk_good = -1; /* Disable optimization! + sbrk_goodness = -1; /* Disable optimization! Continue with not-aligned... */ } else { cp += slack; @@ -1354,7 +1557,7 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) } if (last_sbrk_top) { - sbrk_good -= SBRK_FAILURE_PRICE; + sbrk_goodness -= SBRK_FAILURE_PRICE; } ovp = (union overhead *) cp; @@ -1368,10 +1571,9 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) fatalcroak("Misalignment of sbrk()\n"); else # endif -#ifndef I286 /* Again, this should always be ok on an 80286 */ if (PTR2UV(ovp) & (MEM_ALIGNBYTES - 1)) { DEBUG_m(PerlIO_printf(Perl_debug_log, - "fixing sbrk(): %d bytes off machine alignement\n", + "fixing sbrk(): %d bytes off machine alignment\n", (int)(PTR2UV(ovp) & (MEM_ALIGNBYTES - 1)))); ovp = INT2PTR(union overhead *,(PTR2UV(ovp) + MEM_ALIGNBYTES) & (MEM_ALIGNBYTES - 1)); @@ -1381,12 +1583,13 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) sbrk_slack += (1 << (bucket >> BUCKET_POW2_SHIFT)); # endif } -#endif - ; /* Finish `else' */ + ; /* Finish "else" */ sbrked_remains = require - needed; last_op = cp; } - no_mem = 0; +#if !defined(PLAIN_MALLOC) && !defined(NO_FANCY_MALLOC) + emergency_buffer_last_req = 0; +#endif last_sbrk_top = cp + require; #ifdef DEBUGGING_MSTATS goodsbrk += require; @@ -1424,7 +1627,7 @@ getpages_adjacent(MEM_SIZE require) add_to_chain((void*)(last_sbrk_top - sbrked_remains), sbrked_remains, 0); add_to_chain((void*)cp, require, 0); - sbrk_good -= SBRK_FAILURE_PRICE; + sbrk_goodness -= SBRK_FAILURE_PRICE; sbrked_remains = 0; last_sbrk_top = 0; last_op = 0; @@ -1439,15 +1642,52 @@ getpages_adjacent(MEM_SIZE require) * Allocate more memory to the indicated bucket. */ static void -morecore(register int bucket) +morecore(int bucket) { - register union overhead *ovp; - register int rnu; /* 2^rnu bytes will be requested */ + dVAR; + union overhead *ovp; + int rnu; /* 2^rnu bytes will be requested */ int nblks; /* become nblks blocks of the desired size */ - register MEM_SIZE siz, needed; + MEM_SIZE siz, needed; + static int were_called = 0; if (nextf[bucket]) return; +#ifndef NO_PERL_MALLOC_ENV + if (!were_called) { + /* It's our first time. Initialize ourselves */ + were_called = 1; /* Avoid a loop */ + if (!MallocCfg[MallocCfg_skip_cfg_env]) { + char *s = getenv("PERL_MALLOC_OPT"), *t = s, *off; + const char *opts = PERL_MALLOC_OPT_CHARS; + int changed = 0; + + while ( t && t[0] && t[1] == '=' + && ((off = strchr(opts, *t))) ) { + IV val = 0; + + t += 2; + while (*t <= '9' && *t >= '0') + val = 10*val + *t++ - '0'; + if (!*t || *t == ';') { + if (MallocCfg[off - opts] != val) + changed = 1; + MallocCfg[off - opts] = val; + if (*t) + t++; + } + } + if (t && *t) { + dTHX; + MYMALLOC_WRITE2STDERR("Unrecognized part of PERL_MALLOC_OPT: \""); + MYMALLOC_WRITE2STDERR(t); + MYMALLOC_WRITE2STDERR("\"\n"); + } + if (changed) + MallocCfg[MallocCfg_cfg_env_read] = 1; + } + } +#endif if (bucket == sizeof(MEM_SIZE)*8*BUCKETS_PER_POW2) { MALLOC_UNLOCK; croak("%s", "Out of memory during ridiculously large request"); @@ -1492,12 +1732,13 @@ morecore(register int bucket) if (!ovp) return; + FILL_DEADBEEF((unsigned char*)ovp, needed); /* * Add new memory allocated to that on * free list for this hash bucket. */ - siz = BUCKET_SIZE(bucket); + siz = BUCKET_SIZE_NO_SURPLUS(bucket); /* No surplus if nblks > 1 */ #ifdef PACK_MALLOC *(u_char*)ovp = bucket; /* Fill index. */ if (bucket <= MAX_PACKED) { @@ -1518,6 +1759,7 @@ morecore(register int bucket) start_slack += M_OVERHEAD * nblks; } #endif + while (--nblks > 0) { ovp->ov_next = (union overhead *)((caddr_t)ovp + siz); ovp = (union overhead *)((caddr_t)ovp + siz); @@ -1536,21 +1778,26 @@ morecore(register int bucket) } Free_t -Perl_mfree(void *mp) +Perl_mfree(Malloc_t where) { - register MEM_SIZE size; - register union overhead *ovp; - char *cp = (char*)mp; + dVAR; + MEM_SIZE size; + union overhead *ovp; + char *cp = (char*)where; #ifdef PACK_MALLOC u_char bucket; #endif DEBUG_m(PerlIO_printf(Perl_debug_log, - "0x%"UVxf": (%05lu) free\n", + "0x%" UVxf ": (%05lu) free\n", PTR2UV(cp), (unsigned long)(PL_an++))); if (cp == NULL) return; +#ifdef DEBUGGING + if (PTR2UV(cp) & (MEM_ALIGNBYTES - 1)) + croak("%s", "wrong alignment in free()"); +#endif ovp = (union overhead *)((caddr_t)cp - sizeof (union overhead) * CHUNK_SHIFT); #ifdef PACK_MALLOC @@ -1567,33 +1814,24 @@ Perl_mfree(void *mp) if (bad_free_warn == -1) { dTHX; char *pbf = PerlEnv_getenv("PERL_BADFREE"); - bad_free_warn = (pbf) ? atoi(pbf) : 1; + bad_free_warn = (pbf) ? strNE("0", pbf) : 1; } if (!bad_free_warn) return; #ifdef RCHECK -#ifdef PERL_CORE { dTHX; - if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC)) - Perl_warner(aTHX_ WARN_MALLOC, "%s free() ignored", - ovp->ov_rmagic == RMAGIC - 1 ? - "Duplicate" : "Bad"); + if (!PERL_IS_ALIVE || !PL_curcop) + Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s free() ignored (RMAGIC, PERL_CORE)", + ovp->ov_rmagic == RMAGIC - 1 ? + "Duplicate" : "Bad"); } #else - warn("%s free() ignored", - 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_ WARN_MALLOC, "%s", "Bad free() ignored"); + if (!PERL_IS_ALIVE || !PL_curcop) + Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s", "Bad free() ignored (PERL_CORE)"); } -#else - warn("%s", "Bad free() ignored"); -#endif #endif return; /* sanity */ } @@ -1603,16 +1841,22 @@ Perl_mfree(void *mp) int i; MEM_SIZE nbytes = ovp->ov_size + 1; - if ((i = nbytes & 3)) { - i = 4 - i; - while (i--) { - ASSERT(*((char *)((caddr_t)ovp + nbytes - RSLOP + i)) - == RMAGIC_C, "chunk's tail overwrite"); + if ((i = nbytes & (RMAGIC_SZ-1))) { + i = RMAGIC_SZ - i; + while (i--) { /* nbytes - RMAGIC_SZ is end of alloced area */ + ASSERT(((caddr_t)ovp + nbytes - RMAGIC_SZ)[i] == RMAGIC_C, + "chunk's tail overwrite"); } } - nbytes = (nbytes + 3) &~ 3; - ASSERT(*(u_int *)((caddr_t)ovp + nbytes - RSLOP) == RMAGIC, "chunk's tail overwrite"); + /* Same at RMAGIC_SZ-aligned RMAGIC */ + nbytes = (nbytes + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ-1); + ASSERT(((u_int *)((caddr_t)ovp + nbytes))[-1] == RMAGIC, + "chunk's tail overwrite"); + FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nbytes), + BUCKET_SIZE(OV_INDEX(ovp)) - nbytes); } + FILL_DEADBEEF((unsigned char*)(ovp+CHUNK_SHIFT), + BUCKET_SIZE_REAL(OV_INDEX(ovp)) + RMAGIC_SZ); ovp->ov_rmagic = RMAGIC - 1; #endif ASSERT(OV_INDEX(ovp) < NBUCKETS, "chunk's head overwrite"); @@ -1632,16 +1876,17 @@ Perl_mfree(void *mp) Malloc_t Perl_realloc(void *mp, size_t nbytes) { - register MEM_SIZE onb; + dVAR; + MEM_SIZE onb; union overhead *ovp; char *res; int prev_bucket; - register int bucket; + int bucket; int incr; /* 1 if does not fit, -1 if "easily" fits in a smaller bucket, otherwise 0. */ char *cp = (char*)mp; -#if defined(DEBUGGING) || !defined(PERL_CORE) +#ifdef DEBUGGING MEM_SIZE size = nbytes; if ((long)nbytes < 0) @@ -1667,44 +1912,34 @@ Perl_realloc(void *mp, size_t nbytes) if (bad_free_warn == -1) { dTHX; char *pbf = PerlEnv_getenv("PERL_BADFREE"); - bad_free_warn = (pbf) ? atoi(pbf) : 1; + bad_free_warn = (pbf) ? strNE("0", pbf) : 1; } if (!bad_free_warn) - return Nullch; + return NULL; #ifdef RCHECK -#ifdef PERL_CORE { dTHX; - if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC)) - Perl_warner(aTHX_ WARN_MALLOC, "%srealloc() %signored", - (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "), - ovp->ov_rmagic == RMAGIC - 1 - ? "of freed memory " : ""); + if (!PERL_IS_ALIVE || !PL_curcop) + Perl_ck_warner_d(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_ WARN_MALLOC, "%s", - "Bad realloc() ignored"); + if (!PERL_IS_ALIVE || !PL_curcop) + Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s", + "Bad realloc() ignored"); } -#else - warn("%s", "Bad realloc() ignored"); -#endif #endif - return Nullch; /* sanity */ + return NULL; /* sanity */ } onb = BUCKET_SIZE_REAL(bucket); /* * avoid the copy if same size block. - * We are not agressive with boundary cases. Note that it might + * We are not aggressive with boundary cases. Note that it might * (for a small number of cases) give false negative if * both new size and old one are in the bucket for * FIRST_BIG_POW2, but the new one is near the lower end. @@ -1742,14 +1977,24 @@ Perl_realloc(void *mp, size_t nbytes) if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) { int i, nb = ovp->ov_size + 1; - if ((i = nb & 3)) { - i = 4 - i; - while (i--) { - ASSERT(*((char *)((caddr_t)ovp + nb - RSLOP + i)) == RMAGIC_C, "chunk's tail overwrite"); + if ((i = nb & (RMAGIC_SZ-1))) { + i = RMAGIC_SZ - i; + while (i--) { /* nb - RMAGIC_SZ is end of alloced area */ + ASSERT(((caddr_t)ovp + nb - RMAGIC_SZ)[i] == RMAGIC_C, "chunk's tail overwrite"); } } - nb = (nb + 3) &~ 3; - ASSERT(*(u_int *)((caddr_t)ovp + nb - RSLOP) == RMAGIC, "chunk's tail overwrite"); + /* Same at RMAGIC_SZ-aligned RMAGIC */ + nb = (nb + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ-1); + ASSERT(((u_int *)((caddr_t)ovp + nb))[-1] == RMAGIC, + "chunk's tail overwrite"); + FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nb), + BUCKET_SIZE(OV_INDEX(ovp)) - nb); + if (nbytes > ovp->ov_size + 1 - M_OVERHEAD) + FILL_FEEDADAD((unsigned char*)cp + ovp->ov_size + 1 - M_OVERHEAD, + nbytes - (ovp->ov_size + 1 - M_OVERHEAD)); + else + FILL_DEADBEEF((unsigned char*)cp + nbytes, + nb - M_OVERHEAD + RMAGIC_SZ - nbytes); /* * Convert amount of memory requested into * closest block size stored in hash buckets @@ -1758,19 +2003,20 @@ Perl_realloc(void *mp, size_t nbytes) */ nbytes += M_OVERHEAD; ovp->ov_size = nbytes - 1; - if ((i = nbytes & 3)) { - i = 4 - i; - while (i--) - *((char *)((caddr_t)ovp + nbytes - RSLOP + i)) + if ((i = nbytes & (RMAGIC_SZ-1))) { + i = RMAGIC_SZ - i; + while (i--) /* nbytes - RMAGIC_SZ is end of alloced area */ + ((caddr_t)ovp + nbytes - RMAGIC_SZ)[i] = RMAGIC_C; } - nbytes = (nbytes + 3) &~ 3; - *((u_int *)((caddr_t)ovp + nbytes - RSLOP)) = RMAGIC; + /* Same at RMAGIC_SZ-aligned RMAGIC */ + nbytes = (nbytes + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ - 1); + ((u_int *)((caddr_t)ovp + nbytes))[-1] = RMAGIC; } #endif res = cp; DEBUG_m(PerlIO_printf(Perl_debug_log, - "0x%"UVxf": (%05lu) realloc %ld bytes inplace\n", + "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) @@ -1796,6 +2042,8 @@ Perl_realloc(void *mp, size_t nbytes) nmalloc[bucket]--; nmalloc[pow * BUCKETS_PER_POW2]++; #endif + if (pow * BUCKETS_PER_POW2 > (MEM_SIZE)max_bucket) + max_bucket = pow * BUCKETS_PER_POW2; *(cp - M_OVERHEAD) = pow * BUCKETS_PER_POW2; /* Fill index. */ MALLOC_UNLOCK; goto inplace_label; @@ -1806,7 +2054,7 @@ Perl_realloc(void *mp, size_t nbytes) } else { hard_way: DEBUG_m(PerlIO_printf(Perl_debug_log, - "0x%"UVxf": (%05lu) realloc %ld bytes the hard way\n", + "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) @@ -1819,7 +2067,7 @@ Perl_realloc(void *mp, size_t nbytes) } Malloc_t -Perl_calloc(register size_t elements, register size_t size) +Perl_calloc(size_t elements, size_t size) { long sz = elements * size; Malloc_t p = Perl_malloc(sz); @@ -1836,11 +2084,9 @@ Perl_strdup(const char *s) MEM_SIZE l = strlen(s); char *s1 = (char *)Perl_malloc(l+1); - Copy(s, s1, (MEM_SIZE)(l+1), char); - return s1; + return (char *)CopyD(s, s1, (MEM_SIZE)(l+1), char); } -#ifdef PERL_CORE int Perl_putenv(char *a) { @@ -1860,7 +2106,7 @@ Perl_putenv(char *a) if (l < sizeof(buf)) var = buf; else - var = Perl_malloc(l + 1); + var = (char *)Perl_malloc(l + 1); Copy(a, var, l, char); var[l + 1] = 0; my_setenv(var, val+1); @@ -1868,26 +2114,35 @@ Perl_putenv(char *a) Perl_mfree(var); return 0; } -# endif MEM_SIZE Perl_malloced_size(void *p) { - union overhead *ovp = (union overhead *) + union overhead * const ovp = (union overhead *) ((caddr_t)p - sizeof (union overhead) * CHUNK_SHIFT); - int bucket = OV_INDEX(ovp); + const int bucket = OV_INDEX(ovp); + + PERL_ARGS_ASSERT_MALLOCED_SIZE; + #ifdef RCHECK /* The caller wants to have a complete control over the chunk, disable the memory checking inside the chunk. */ if (bucket <= MAX_SHORT_BUCKET) { - MEM_SIZE size = BUCKET_SIZE_REAL(bucket); + const MEM_SIZE size = BUCKET_SIZE_REAL(bucket); ovp->ov_size = size + M_OVERHEAD - 1; - *((u_int *)((caddr_t)ovp + size + M_OVERHEAD - RSLOP)) = RMAGIC; + *((u_int *)((caddr_t)ovp + size + M_OVERHEAD - RMAGIC_SZ)) = RMAGIC; } #endif return BUCKET_SIZE_REAL(bucket); } + +MEM_SIZE +Perl_malloc_good_size(size_t wanted) +{ + return BUCKET_SIZE_REAL(adjust_size_and_find_bucket(&wanted)); +} + # ifdef BUCKETS_ROOT2 # define MIN_EVEN_REPORT 6 # else @@ -1898,10 +2153,12 @@ 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 i, j; + union overhead *p; struct chunk_chain_s* nextchain; + PERL_ARGS_ASSERT_GET_MSTATS; + buf->topbucket = buf->topbucket_ev = buf->topbucket_odd = buf->totfree = buf->total = buf->total_chain = 0; @@ -1928,7 +2185,7 @@ Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level) } buf->total_sbrk = goodsbrk + sbrk_slack; buf->sbrks = sbrks; - buf->sbrk_good = sbrk_good; + buf->sbrk_good = sbrk_goodness; buf->sbrk_slack = sbrk_slack; buf->start_slack = start_slack; buf->sbrked_remains = sbrked_remains; @@ -1938,10 +2195,12 @@ Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level) for (i = MIN_BUCKET ; i < NBUCKETS; i++) { if (i >= buflen) break; - buf->bucket_mem_size[i] = BUCKET_SIZE(i); + buf->bucket_mem_size[i] = BUCKET_SIZE_NO_SURPLUS(i); buf->bucket_available_size[i] = BUCKET_SIZE_REAL(i); } } +#else /* defined DEBUGGING_MSTATS */ + PerlIO_printf(Perl_error_log, "perl not compiled with DEBUGGING_MSTATS\n"); #endif /* defined DEBUGGING_MSTATS */ return 0; /* XXX unused */ } @@ -1953,27 +2212,30 @@ Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level) * frees for each size category. */ void -Perl_dump_mstats(pTHX_ char *s) +Perl_dump_mstats(pTHX_ const char *s) { #ifdef DEBUGGING_MSTATS - register int i; + int i; perl_mstats_t buffer; UV nf[NBUCKETS]; UV nt[NBUCKETS]; + PERL_ARGS_ASSERT_DUMP_MSTATS; + buffer.nfree = nf; buffer.ntotal = nt; get_mstats(&buffer, NBUCKETS, 0); if (s) PerlIO_printf(Perl_error_log, - "Memory allocation statistics %s (buckets %"IVdf"(%"IVdf")..%"IVdf"(%"IVdf")\n", + "Memory allocation statistics %s (buckets %" IVdf + "(%" IVdf ")..%" IVdf "(%" IVdf ")\n", s, (IV)BUCKET_SIZE_REAL(MIN_BUCKET), - (IV)BUCKET_SIZE(MIN_BUCKET), + (IV)BUCKET_SIZE_NO_SURPLUS(MIN_BUCKET), (IV)BUCKET_SIZE_REAL(buffer.topbucket), - (IV)BUCKET_SIZE(buffer.topbucket)); - PerlIO_printf(Perl_error_log, "%8"IVdf" free:", buffer.totfree); + (IV)BUCKET_SIZE_NO_SURPLUS(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) @@ -1991,7 +2253,8 @@ Perl_dump_mstats(pTHX_ char *s) buffer.nfree[i]); } #endif - PerlIO_printf(Perl_error_log, "\n%8"IVdf" 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) @@ -2009,17 +2272,20 @@ Perl_dump_mstats(pTHX_ char *s) buffer.ntotal[i] - buffer.nfree[i]); } #endif - PerlIO_printf(Perl_error_log, "\nTotal sbrk(): %"IVdf"/%"IVdf":%"IVdf". Odd ends: pad+heads+chain+tail: %"IVdf"+%"IVdf"+%"IVdf"+%"IVdf".\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); +#else /* DEBUGGING_MSTATS */ + PerlIO_printf(Perl_error_log, "%s: perl not compiled with DEBUGGING_MSTATS\n",s); #endif /* DEBUGGING_MSTATS */ } -#endif /* lint */ #ifdef USE_PERL_SBRK -# if defined(__MACHTEN_PPC__) || defined(NeXT) || defined(__NeXT__) || defined(PURIFY) +# if defined(PURIFY) # define PERL_SBRK_VIA_MALLOC # endif @@ -2052,9 +2318,7 @@ Perl_sbrk(int size) int small, reqsize; if (!size) return 0; -#ifdef PERL_CORE reqsize = size; /* just for the DEBUG_m statement */ -#endif #ifdef PACK_MALLOC size = (size + 0x7ff) & ~0x7ff; #endif @@ -2083,10 +2347,16 @@ Perl_sbrk(int size) } } - 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))); + 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; } #endif /* ! defined USE_PERL_SBRK */ + +/* + * ex: set ts=8 sts=4 sw=4 et: + */