X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/eb578fdb5569b91c28466a4d1939e381ff6ceaf4..3d92c6b8aa91a3ee216dd4aafedacd8b6e129803:/malloc.c?ds=sidebyside diff --git a/malloc.c b/malloc.c index f658489..01e84bf 100644 --- a/malloc.c +++ b/malloc.c @@ -253,6 +253,10 @@ # define PERL_MAYBE_ALIVE 1 #endif +#ifndef MYMALLOC +# error "MYMALLOC is not defined" +#endif + #ifndef MUTEX_LOCK # define MUTEX_LOCK(l) #endif @@ -462,12 +466,12 @@ static const u_short buck_size[MAX_BUCKET_BY_TABLE + 1] = }; # 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_NO_SURPLUS(i) (1 << ((i) >> BUCKET_POW2_SHIFT)) +# 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 @@ -592,7 +596,7 @@ static const u_short buck_size[MAX_BUCKET_BY_TABLE + 1] = # define MAX_PACKED_POW2 6 # define MAX_PACKED (MAX_PACKED_POW2 * BUCKETS_PER_POW2 + BUCKET_POW2_SHIFT) # define MAX_POW2_ALGO ((1<<(MAX_PACKED_POW2 + 1)) - M_OVERHEAD) -# define TWOK_MASK ((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 */ -#ifdef HAS_64K_LIMIT -# 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 */ -# define BARK_64K_LIMIT(what,nbytes,size) -#endif /* !HAS_64K_LIMIT */ +#define BARK_64K_LIMIT(what,nbytes,size) #ifndef MIN_SBRK # define MIN_SBRK 2048 @@ -787,7 +782,7 @@ static const 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 (const char *diag, const char *s, const char *file, int line); # endif @@ -827,32 +822,14 @@ static union overhead *nextf[NBUCKETS]; #ifdef USE_PERL_SBRK # define sbrk(a) Perl_sbrk(a) Malloc_t Perl_sbrk (int size); -#else -# ifndef HAS_SBRK_PROTO /* usually takes care of this */ +#elif !defined(HAS_SBRK_PROTO) /* usually takes care of this */ extern Malloc_t sbrk(int); -# endif #endif #ifndef MIN_SBRK_FRAC1000 /* Backward compatibility */ # define MIN_SBRK_FRAC1000 (MIN_SBRK_FRAC * 10) #endif -#ifndef START_EXTERN_C -# ifdef __cplusplus -# define START_EXTERN_C extern "C" { -# else -# define START_EXTERN_C -# endif -#endif - -#ifndef END_EXTERN_C -# ifdef __cplusplus -# define END_EXTERN_C }; -# else -# define END_EXTERN_C -# endif -#endif - #include "malloc_ctl.h" #ifndef NO_MALLOC_DYNAMIC_CFG @@ -1004,27 +981,9 @@ get_emergency_buffer(IV *size) return pv; } -/* Returns 0 on success, -1 on bad alignment, -2 if not implemented */ -int -set_emergency_buffer(char *b, IV size) -{ - if (PTR2UV(b) & (NEEDED_ALIGNMENT - 1)) - return -1; - if (MallocCfg[MallocCfg_emergency_buffer_prepared_size]) - add_to_chain((void*)emergency_buffer_prepared, - MallocCfg[MallocCfg_emergency_buffer_prepared_size], 0); - emergency_buffer_prepared = b; - MallocCfg[MallocCfg_emergency_buffer_prepared_size] = size; - return 0; -} # define GET_EMERGENCY_BUFFER(p) get_emergency_buffer(p) # else /* NO_MALLOC_DYNAMIC_CFG */ # define GET_EMERGENCY_BUFFER(p) NULL -int -set_emergency_buffer(char *b, IV size) -{ - return -1; -} # endif static Malloc_t @@ -1038,7 +997,9 @@ emergency_sbrk(MEM_SIZE size) /* 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)); + emergency_sbrk_croak("Out of memory during \"large\" request for %" UVuf + " bytes, total sbrk() is %" UVuf " bytes", + (UV)size, (UV)(goodsbrk + sbrk_slack)); } if ((MEM_SIZE)emergency_buffer_size >= rsize) { @@ -1082,8 +1043,10 @@ 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)); - assert(0); /* NOTREACHED */ + emergency_sbrk_croak("Out of memory during request for %" UVuf + " bytes, total sbrk() is %" UVuf " bytes", + (UV)size, (UV)(goodsbrk + sbrk_slack)); + NOT_REACHED; /* NOTREACHED */ return NULL; } @@ -1091,11 +1054,8 @@ emergency_sbrk(MEM_SIZE size) # define emergency_sbrk(size) -1 #endif /* defined PERL_EMERGENCY_SBRK */ -static void -write2(const 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 @@ -1104,7 +1064,6 @@ write2(const char *mess) static void botch(const char *diag, const char *s, const char *file, int line) { - dVAR; dTHX; if (!(PERL_MAYBE_ALIVE && PERL_GET_THX)) goto do_write; @@ -1113,13 +1072,13 @@ botch(const char *diag, const char *s, const char *file, int line) "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; @@ -1128,9 +1087,9 @@ botch(const char *diag, const char *s, const char *file, int line) do { *--s = '0' + (n % 10); } while (n /= 10); - write2(s); + MYMALLOC_WRITE2STDERR(s); } - write2(")\n"); + MYMALLOC_WRITE2STDERR(")\n"); } PerlProc_abort(); } @@ -1215,12 +1174,16 @@ cmp_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill) # define FILLCHECK_DEADBEEF(s, n) ((void)0) #endif -int -S_ajust_size_and_find_bucket(size_t *nbytes_p) +STATIC int +S_adjust_size_and_find_bucket(size_t *nbytes_p) { - MEM_SIZE shiftr; + MEM_SIZE shiftr; int bucket; - size_t nbytes = *nbytes_p; + size_t nbytes; + + PERL_ARGS_ASSERT_ADJUST_SIZE_AND_FIND_BUCKET; + + nbytes = *nbytes_p; /* * Convert amount of memory requested into @@ -1259,24 +1222,44 @@ S_ajust_size_and_find_bucket(size_t *nbytes_p) return bucket; } +/* +These have the same interfaces as the C lib ones, so are considered documented + +=for apidoc malloc +=for apidoc calloc +=for apidoc realloc +=cut +*/ + Malloc_t Perl_malloc(size_t nbytes) { - dVAR; union overhead *p; int bucket; - #if defined(DEBUGGING) || defined(RCHECK) MEM_SIZE size = nbytes; #endif + /* A structure that has more than PTRDIFF_MAX bytes is unfortunately + * legal in C, but in such, if two elements are far enough apart, we + * can't legally find out how far apart they are. Limit the size of a + * malloc so that pointer subtraction in the same structure is always + * well defined */ + if (nbytes > PTRDIFF_MAX) { + dTHX; + MYMALLOC_WRITE2STDERR("Memory requests are limited to PTRDIFF_MAX" + " bytes to prevent possible undefined" + " behavior"); + return NULL; + } + BARK_64K_LIMIT("Allocation",nbytes,nbytes); #ifdef DEBUGGING if ((long)nbytes < 0) croak("%s", "panic: malloc"); #endif - bucket = S_ajust_size_and_find_bucket(&nbytes); + bucket = adjust_size_and_find_bucket(&nbytes); MALLOC_LOCK; /* * If nothing in hash bucket right now, @@ -1290,14 +1273,14 @@ Perl_malloc(size_t nbytes) 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 @@ -1305,15 +1288,15 @@ Perl_malloc(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); } @@ -1328,7 +1311,7 @@ Perl_malloc(size_t nbytes) || (p && PTR2UV(p) < (1<ov_next) & (MEM_ALIGNBYTES - 1)) @@ -1336,7 +1319,7 @@ Perl_malloc(size_t nbytes) dTHX; PerlIO_printf(PerlIO_stderr(), "Unaligned \"next\" pointer in the free " - "chain 0x%"UVxf" at 0x%"UVxf"\n", + "chain 0x%" UVxf " at 0x%" UVxf "\n", PTR2UV(p->ov_next), PTR2UV(p)); } #endif @@ -1345,8 +1328,9 @@ Perl_malloc(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++), + "%p: (%05lu) malloc %ld bytes\n", + (Malloc_t)(p + CHUNK_SHIFT), + (unsigned long)(PL_an++), (long)size)); FILLCHECK_DEADBEEF((unsigned char*)(p + CHUNK_SHIFT), @@ -1485,7 +1469,6 @@ 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; @@ -1550,7 +1533,7 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) 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); @@ -1678,9 +1661,8 @@ getpages_adjacent(MEM_SIZE require) * Allocate more memory to the indicated bucket. */ static void -morecore(register int bucket) +morecore(int bucket) { - dVAR; union overhead *ovp; int rnu; /* 2^rnu bytes will be requested */ int nblks; /* become nblks blocks of the desired size */ @@ -1691,10 +1673,11 @@ morecore(register int bucket) return; #ifndef NO_PERL_MALLOC_ENV if (!were_called) { - /* It's the our first time. Initialize ourselves */ + /* 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; + char *s = getenv("PERL_MALLOC_OPT"), *t = s; + const char *off; const char *opts = PERL_MALLOC_OPT_CHARS; int changed = 0; @@ -1703,7 +1686,7 @@ morecore(register int bucket) IV val = 0; t += 2; - while (*t <= '9' && *t >= '0') + while (isDIGIT(*t)) val = 10*val + *t++ - '0'; if (!*t || *t == ';') { if (MallocCfg[off - opts] != val) @@ -1714,9 +1697,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; @@ -1815,7 +1799,6 @@ morecore(register int bucket) Free_t Perl_mfree(Malloc_t where) { - dVAR; MEM_SIZE size; union overhead *ovp; char *cp = (char*)where; @@ -1824,7 +1807,7 @@ Perl_mfree(Malloc_t where) #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) @@ -1849,7 +1832,7 @@ Perl_mfree(Malloc_t where) 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; @@ -1911,7 +1894,6 @@ Perl_mfree(Malloc_t where) Malloc_t Perl_realloc(void *mp, size_t nbytes) { - dVAR; MEM_SIZE onb; union overhead *ovp; char *res; @@ -1947,7 +1929,7 @@ 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 NULL; @@ -2051,7 +2033,7 @@ Perl_realloc(void *mp, size_t nbytes) #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) @@ -2089,7 +2071,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) @@ -2102,7 +2084,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); @@ -2175,7 +2157,7 @@ Perl_malloced_size(void *p) MEM_SIZE Perl_malloc_good_size(size_t wanted) { - return BUCKET_SIZE_REAL(S_ajust_size_and_find_bucket(&wanted)); + return BUCKET_SIZE_REAL(adjust_size_and_find_bucket(&wanted)); } # ifdef BUCKETS_ROOT2 @@ -2263,18 +2245,20 @@ Perl_dump_mstats(pTHX_ const char *s) 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_NO_SURPLUS(MIN_BUCKET), (IV)BUCKET_SIZE_REAL(buffer.topbucket), (IV)BUCKET_SIZE_NO_SURPLUS(buffer.topbucket)); - PerlIO_printf(Perl_error_log, "%8"IVdf" free:", buffer.totfree); + 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) - ? " %5"UVuf - : ((i < 12*BUCKETS_PER_POW2) ? " %3"UVuf : " %"UVuf)), + ? " %5" UVuf + : ((i < 12*BUCKETS_PER_POW2) ? " %3" UVuf + : " %" UVuf)), buffer.nfree[i]); } #ifdef BUCKETS_ROOT2 @@ -2287,12 +2271,13 @@ Perl_dump_mstats(pTHX_ const 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) - ? " %5"IVdf - : ((i < 12*BUCKETS_PER_POW2) ? " %3"IVdf : " %"IVdf)), + ? " %5" IVdf + : ((i < 12*BUCKETS_PER_POW2) ? " %3" IVdf : " %" IVdf)), buffer.ntotal[i] - buffer.nfree[i]); } #ifdef BUCKETS_ROOT2 @@ -2305,7 +2290,9 @@ Perl_dump_mstats(pTHX_ const 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); @@ -2316,7 +2303,7 @@ Perl_dump_mstats(pTHX_ const char *s) #ifdef USE_PERL_SBRK -# if defined(NeXT) || defined(__NeXT__) || defined(PURIFY) +# if defined(PURIFY) # define PERL_SBRK_VIA_MALLOC # endif @@ -2378,8 +2365,10 @@ 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; } @@ -2387,11 +2376,5 @@ 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: */