X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/41ad8e4261642146314ec7332abffcab995f9fc9..9555a685dbd794b0e9f549335341b2a3b1ea3da5:/malloc.c diff --git a/malloc.c b/malloc.c index 409eed5..a331550 100644 --- a/malloc.c +++ b/malloc.c @@ -6,6 +6,12 @@ * "'The Chamber of Records,' said Gimli. 'I guess that is where we now stand.'" */ +/* 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.) @@ -265,19 +271,18 @@ # define LOG_OF_MIN_ARENA 14 #endif -#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. @@ -357,6 +362,7 @@ # define Free_t void # endif # define Copy(s,d,n,t) (void)memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) +# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) # define PerlEnv_getenv getenv # define PerlIO_printf fprintf # define PerlIO_stderr() stderr @@ -402,7 +408,7 @@ # ifndef pTHX # define pTHX void # define pTHX_ -# ifdef HASATTRIBUTE +# ifdef HASATTRIBUTE_UNUSED # define dTHX extern int Perl___notused PERL_UNUSED_DECL # else # define dTHX extern int Perl___notused @@ -566,6 +572,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 { /* @@ -576,6 +585,7 @@ union overhead { u_char ovu_index; /* bucket # */ u_char ovu_magic; /* magic number */ #ifdef RCHECK + /* 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 @@ -591,14 +601,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) /* 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) @@ -630,19 +640,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)) \ - 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) (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 @@ -787,13 +798,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<>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; @@ -1280,7 +1300,7 @@ botch(char *diag, char *s, char *file, int line) 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 ("); @@ -1316,7 +1336,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)); @@ -1357,7 +1377,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)); @@ -1495,7 +1515,7 @@ Perl_malloc(register size_t nbytes) || (p->ov_next && PTR2UV(p->ov_next) < (1<ov_next), PTR2UV(p)); } @@ -1510,7 +1530,7 @@ Perl_malloc(register size_t nbytes) (long)size)); FILLCHECK_DEADBEEF((unsigned char*)(p + CHUNK_SHIFT), - BUCKET_SIZE_REAL(bucket)); + BUCKET_SIZE_REAL(bucket) + RMAGIC_SZ); #ifdef IGNORE_SMALL_BAD_FREE if (bucket >= FIRST_BUCKET_WITH_CHECK) @@ -1530,13 +1550,14 @@ 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 @@ -1631,7 +1652,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; @@ -1652,9 +1673,9 @@ 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) require = goodsbrk * MIN_SBRK_FRAC1000 / 1000; @@ -1783,7 +1804,7 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) # endif } #endif - ; /* Finish `else' */ + ; /* Finish "else" */ sbrked_remains = require - needed; last_op = cp; } @@ -1877,9 +1898,9 @@ morecore(register int bucket) } } if (t && *t) { - write2("Unrecognized part of PERL_MALLOC_OPT: `"); + write2("Unrecognized part of PERL_MALLOC_OPT: \""); write2(t); - write2("'\n"); + write2("\"\n"); } if (changed) MallocCfg[MallocCfg_cfg_env_read] = 1; @@ -1936,7 +1957,7 @@ morecore(register int bucket) * 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) { @@ -2047,19 +2068,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"); - FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nbytes - RSLOP + sizeof(u_int)), - BUCKET_SIZE_REAL(OV_INDEX(ovp)) - (nbytes - RSLOP + sizeof(u_int))); + /* 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+1), BUCKET_SIZE_REAL(OV_INDEX(ovp))); + 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"); @@ -2189,22 +2213,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"); - FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nb - RSLOP + sizeof(u_int)), - BUCKET_SIZE_REAL(OV_INDEX(ovp)) - (nb - RSLOP + sizeof(u_int))); + /* 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 + RSLOP - nbytes); + nb - M_OVERHEAD + RMAGIC_SZ - nbytes); /* * Convert amount of memory requested into * closest block size stored in hash buckets @@ -2213,14 +2239,15 @@ 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; @@ -2291,8 +2318,7 @@ 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 CopyD(s, s1, (MEM_SIZE)(l+1), char); } #ifdef PERL_CORE @@ -2328,16 +2354,16 @@ Perl_putenv(char *a) 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); #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); @@ -2393,7 +2419,7 @@ 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); } } @@ -2425,9 +2451,9 @@ Perl_dump_mstats(pTHX_ char *s) "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)); + (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, @@ -2470,7 +2496,6 @@ Perl_dump_mstats(pTHX_ char *s) buffer.total_chain, buffer.sbrked_remains); #endif /* DEBUGGING_MSTATS */ } -#endif /* lint */ #ifdef USE_PERL_SBRK @@ -2545,3 +2570,13 @@ Perl_sbrk(int size) } #endif /* ! defined USE_PERL_SBRK */ + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */