X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d0bbed784b85a44e92a8a0e3d4046ce7f236db02..fb3a67619e8a1f5d6bf5a80777fc74459e0e35b6:/malloc.c diff --git a/malloc.c b/malloc.c index e3c1449..a99663e 100644 --- a/malloc.c +++ b/malloc.c @@ -3,13 +3,20 @@ */ /* - * "'The Chamber of Records,' said Gimli. 'I guess that is where we now stand.'" + * '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. (For non-perl - usage see below.) - + 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 @@ -32,10 +39,10 @@ # Enable code for an emergency memory pool in $^M. See perlvar.pod # for a description of $^M. - PERL_EMERGENCY_SBRK (!PLAIN_MALLOC && (PERL_CORE || !NO_MALLOC_DYNAMIC_CFG)) + 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 @@ -155,72 +162,6 @@ */ -/* - 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 - - # Signed integer of the same sizeof() as UV - IV long - - # Type of pointer with 1-byte granularity - caddr_t char * - - # Type returned by free() - Free_t void - - # Conversion of pointer to integer - PTR2UV(ptr) ((UV)(ptr)) - - # Conversion of integer to pointer - INT2PTR(type, i) ((type)(i)) - - # printf()-%-Conversion of UV to pointer - UVuf "lu" - - # printf()-%-Conversion of UV to hex pointer - UVxf "lx" - - # Alignment to use - MEM_ALIGNBYTES 4 - - # 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) - - # 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" @@ -245,10 +186,10 @@ # ifndef TWO_POT_OPTIMIZE # define TWO_POT_OPTIMIZE # endif -# if (defined(PERL_CORE) || !defined(NO_MALLOC_DYNAMIC_CFG)) && !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 @@ -256,28 +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(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 +#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. @@ -296,139 +229,29 @@ * 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 -# if defined(USE_5005THREADS) || defined(USE_ITHREADS) +#endif +#ifdef USE_ITHREADS # define PERL_MAYBE_ALIVE PL_thr_key -# else -# define PERL_MAYBE_ALIVE 1 -# endif #else -# ifdef PERL_FOR_X2P -# include "../EXTERN.h" -# include "../perl.h" -# else -# include -# include -# include -# ifdef OS2 -# include -# endif -# include -# 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 IV -# define IV 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 -# define PerlIO_puts(f,s) fputs(s,f) -# ifndef INT2PTR -# define INT2PTR(t,i) ((t)(i)) -# endif -# ifndef PTR2UV -# define PTR2UV(p) ((UV)(p)) -# endif -# ifndef UVuf -# define UVuf "lu" -# endif -# ifndef UVxf -# define UVxf "lx" -# endif -# ifndef Nullch -# define Nullch NULL -# endif -# ifndef MEM_ALIGNBYTES -# define MEM_ALIGNBYTES 4 -# endif -# 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 warn2 -# define warn2(mess, arg1, arg2) 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_ -# 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 -# define PERL_GET_INTERP PL_curinterp -# endif -# define PERL_MAYBE_ALIVE 1 -# 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 -#endif /* defined PERL_CORE */ +# define PERL_MAYBE_ALIVE 1 +#endif #ifndef MUTEX_LOCK # define MUTEX_LOCK(l) @@ -546,8 +369,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 @@ -566,6 +388,9 @@ 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 { /* @@ -622,7 +447,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 @@ -631,7 +456,7 @@ 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, }; @@ -681,7 +506,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 @@ -795,7 +620,7 @@ static u_short buck_size[MAX_BUCKET_BY_TABLE + 1] = # define N_BLKS(bucket) n_blks[bucket] #endif -static u_short n_blks[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] = +static const u_short n_blks[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] = { # if BUCKETS_PER_POW2==1 0, 0, @@ -818,7 +643,7 @@ static u_short n_blks[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] = # define BLK_SHIFT(bucket) blk_shift[bucket] #endif -static u_short blk_shift[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] = +static const u_short blk_shift[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] = { # if BUCKETS_PER_POW2==1 0, 0, @@ -866,7 +691,7 @@ static u_short blk_shift[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] = # else # define SIZE_TABLE_MAX 64 # endif -static char bucket_of[] = +static const char bucket_of[] = { # ifdef BUCKETS_ROOT2 /* Chunks of size 3*2^n. */ /* 0 to 15 in 4-byte increments. */ @@ -930,16 +755,7 @@ static char bucket_of[] = # define POW2_OPTIMIZE_SURPLUS(bucket) 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 @@ -962,9 +778,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, char *file, int line); +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); @@ -972,8 +788,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); -#ifdef PERL_CORE - #ifdef I_MACH_CTHREADS # undef MUTEX_LOCK # define MUTEX_LOCK(m) STMT_START { if (*m) mutex_lock(*m); } STMT_END @@ -981,8 +795,6 @@ static int getpages_adjacent(MEM_SIZE require); # define MUTEX_UNLOCK(m) STMT_START { if (*m) mutex_unlock(*m); } STMT_END #endif -#endif /* defined PERL_CORE */ - #ifndef PTRSIZE # define PTRSIZE sizeof(void*) #endif @@ -1065,6 +877,12 @@ static IV MallocCfg[MallocCfg_last] = { }; 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 @@ -1087,6 +905,9 @@ IV *MallocCfg_ptr = MallocCfg; # 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 @@ -1118,38 +939,35 @@ static u_int goodsbrk; # define BIG_SIZE (1<<16) /* 64K */ # endif -static char *emergency_buffer; -static char *emergency_buffer_prepared; - # ifdef NO_MALLOC_DYNAMIC_CFG static MEM_SIZE emergency_buffer_size; /* 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 -# ifdef PERL_CORE static char * perl_get_emergency_buffer(IV *size) { 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; - STRLEN n_a; + GV **gvp = (GV**)hv_fetchs(PL_defstash, "^M", FALSE); - if (!gvp) gvp = (GV**)hv_fetch(PL_defstash, "\015", 1, 0); + 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 - && (!emergency_buffer_last_req || (size < emergency_buffer_last_req))) { + && (!emergency_buffer_last_req || + (size < (MEM_SIZE)emergency_buffer_last_req))) { /* Give the possibility to recover, but avoid an infinite cycle. */ MALLOC_UNLOCK; 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; @@ -1231,7 +1030,7 @@ emergency_sbrk(MEM_SIZE size) 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; } @@ -1257,41 +1056,40 @@ emergency_sbrk(MEM_SIZE size) do_croak: MALLOC_UNLOCK; emergency_sbrk_croak("Out of memory during request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack)); - /* NOTREACHED */ - return Nullch; + assert(0); /* NOTREACHED */ + return NULL; } #else /* !defined(PERL_EMERGENCY_SBRK) */ # define emergency_sbrk(size) -1 #endif /* defined PERL_EMERGENCY_SBRK */ -static void -write2(char *mess) -{ - write(2, mess, strlen(mess)); -} +/* Don't use PerlIO buffered writes as they allocate memory. */ +#define MYMALLOC_WRITE2STDERR(s) PERL_UNUSED_RESULT(PerlLIO_write(PerlIO_fileno(PerlIO_stderr()),s,strlen(s))) #ifdef DEBUGGING #undef ASSERT -#define ASSERT(p,diag) if (!(p)) botch(diag,STRINGIFY(p),__FILE__,__LINE__); else +#define ASSERT(p,diag) if (!(p)) botch(diag,STRINGIFY(p),__FILE__,__LINE__); + static void -botch(char *diag, char *s, char *file, int line) +botch(const char *diag, const char *s, const char *file, int line) { + dVAR; + dTHX; if (!(PERL_MAYBE_ALIVE && PERL_GET_THX)) goto do_write; else { - dTHX; if (PerlIO_printf(PerlIO_stderr(), - "assertion botched (%s?): %s%s %s:%d\n", + "assertion botched (%s?): %s %s:%d\n", diag, s, file, line) != 0) { do_write: /* Can be initializing interpreter */ - write2("assertion botched ("); - write2(diag); - write2("?): "); - write2(s); - write2(" ("); - write2(file); - write2(":"); + MYMALLOC_WRITE2STDERR("assertion botched ("); + MYMALLOC_WRITE2STDERR(diag); + MYMALLOC_WRITE2STDERR("?): "); + MYMALLOC_WRITE2STDERR(s); + MYMALLOC_WRITE2STDERR(" ("); + MYMALLOC_WRITE2STDERR(file); + MYMALLOC_WRITE2STDERR(":"); { char linebuf[10]; char *s = linebuf + sizeof(linebuf) - 1; @@ -1300,9 +1098,9 @@ botch(char *diag, char *s, char *file, int line) do { *--s = '0' + (n % 10); } while (n /= 10); - write2(s); + MYMALLOC_WRITE2STDERR(s); } - write2(")\n"); + MYMALLOC_WRITE2STDERR(")\n"); } PerlProc_abort(); } @@ -1318,7 +1116,7 @@ fill_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill) { unsigned char *e = s + nbytes; long *lp; - long lfill = *(long*)fill; + const long lfill = *(long*)fill; if (PTR2UV(s) & (sizeof(long)-1)) { /* Align the pattern */ int shift = sizeof(long) - (PTR2UV(s) & (sizeof(long)-1)); @@ -1359,7 +1157,7 @@ cmp_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill) { unsigned char *e = s + nbytes; long *lp; - long lfill = *(long*)fill; + const long lfill = *(long*)fill; if (PTR2UV(s) & (sizeof(long)-1)) { /* Align the pattern */ int shift = sizeof(long) - (PTR2UV(s) & (sizeof(long)-1)); @@ -1387,22 +1185,16 @@ cmp_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill) # define FILLCHECK_DEADBEEF(s, n) ((void)0) #endif -Malloc_t -Perl_malloc(register size_t nbytes) +STATIC int +S_adjust_size_and_find_bucket(size_t *nbytes_p) { - register union overhead *p; - register int bucket; - register MEM_SIZE shiftr; + MEM_SIZE shiftr; + int bucket; + size_t nbytes; -#if defined(DEBUGGING) || defined(RCHECK) - MEM_SIZE size = nbytes; -#endif + PERL_ARGS_ASSERT_ADJUST_SIZE_AND_FIND_BUCKET; - BARK_64K_LIMIT("Allocation",nbytes,nbytes); -#ifdef DEBUGGING - if ((long)nbytes < 0) - croak("%s", "panic: malloc"); -#endif + nbytes = *nbytes_p; /* * Convert amount of memory requested into @@ -1437,6 +1229,28 @@ Perl_malloc(register size_t nbytes) 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, @@ -1446,19 +1260,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) - PerlIO_puts(PerlIO_stderr(),"Out of memory!\n"); + 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 @@ -1466,20 +1279,19 @@ 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); } @@ -1497,7 +1309,7 @@ Perl_malloc(register size_t nbytes) || (p->ov_next && PTR2UV(p->ov_next) < (1<ov_next), PTR2UV(p)); } @@ -1647,6 +1459,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; @@ -1655,11 +1468,11 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) MEM_SIZE slack = 0; if (sbrk_goodness > 0) { - if (!last_sbrk_top && require < FIRST_SBRK) + 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_FRAC1000 / 1000) + 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 { @@ -1702,16 +1515,12 @@ 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, @@ -1772,10 +1581,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)); @@ -1785,8 +1593,7 @@ 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; } @@ -1845,12 +1652,13 @@ 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]) @@ -1880,9 +1688,10 @@ morecore(register int bucket) } } if (t && *t) { - write2("Unrecognized part of PERL_MALLOC_OPT: `"); - write2(t); - write2("'\n"); + dTHX; + MYMALLOC_WRITE2STDERR("Unrecognized part of PERL_MALLOC_OPT: \""); + MYMALLOC_WRITE2STDERR(t); + MYMALLOC_WRITE2STDERR("\"\n"); } if (changed) MallocCfg[MallocCfg_cfg_env_read] = 1; @@ -1979,11 +1788,12 @@ 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 @@ -2019,28 +1829,19 @@ Perl_mfree(void *mp) if (!bad_free_warn) return; #ifdef RCHECK -#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"); + 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 (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)"); + 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 */ } @@ -2085,16 +1886,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) @@ -2123,41 +1925,31 @@ Perl_realloc(void *mp, size_t nbytes) bad_free_warn = (pbf) ? atoi(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_ packWARN(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 - warn2("%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"); + 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. @@ -2260,6 +2052,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; @@ -2283,7 +2077,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); @@ -2300,11 +2094,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) { @@ -2324,7 +2116,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); @@ -2332,19 +2124,21 @@ 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 - RMAGIC_SZ)) = RMAGIC; } @@ -2352,6 +2146,13 @@ Perl_malloced_size(void *p) 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 @@ -2362,10 +2163,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; @@ -2406,6 +2209,8 @@ Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level) 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 */ } @@ -2417,14 +2222,16 @@ 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); @@ -2477,13 +2284,14 @@ Perl_dump_mstats(pTHX_ char *s) 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 @@ -2516,9 +2324,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 @@ -2554,3 +2360,13 @@ Perl_sbrk(int size) } #endif /* ! defined USE_PERL_SBRK */ + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: nil + * End: + * + * ex: set ts=8 sts=4 sw=4 et: + */