X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/6af660ee01c05048b7704273e88e9249deb8202f..574fde551fdfac289d149541a993a1583cb6c618:/malloc.c diff --git a/malloc.c b/malloc.c index 6013e40..adfa23a 100644 --- a/malloc.c +++ b/malloc.c @@ -3,7 +3,15 @@ */ /* - * "'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. */ /* @@ -256,7 +264,7 @@ #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__)) +#if !(defined(I286) || defined(atarist)) /* take 2k unless the block is bigger than that */ # define LOG_OF_MIN_ARENA 11 #else @@ -265,19 +273,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 +364,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 @@ -373,9 +381,6 @@ # ifndef UVxf # define UVxf "lx" # endif -# ifndef Nullch -# define Nullch NULL -# endif # ifndef MEM_ALIGNBYTES # define MEM_ALIGNBYTES 4 # endif @@ -402,7 +407,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 @@ -547,7 +552,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(I286) || defined(atarist)) && defined(PACK_MALLOC) # undef PACK_MALLOC #endif @@ -634,7 +639,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, }; @@ -798,7 +803,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, @@ -821,7 +826,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, @@ -869,7 +874,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. */ @@ -967,7 +972,7 @@ static char bucket_of[] = static void morecore (register 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); @@ -1150,17 +1155,16 @@ 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; @@ -1242,7 +1248,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; } @@ -1269,7 +1275,7 @@ emergency_sbrk(MEM_SIZE size) 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; + return NULL; } #else /* !defined(PERL_EMERGENCY_SBRK) */ @@ -1277,21 +1283,23 @@ emergency_sbrk(MEM_SIZE size) #endif /* defined PERL_EMERGENCY_SBRK */ static void -write2(char *mess) +write2(const char *mess) { write(2, mess, strlen(mess)); } #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:%d\n", diag, s, file, line) != 0) { @@ -1329,7 +1337,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)); @@ -1370,7 +1378,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)); @@ -1398,22 +1406,12 @@ 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) +int +S_ajust_size_and_find_bucket(size_t *nbytes_p) { - register union overhead *p; - register int bucket; - register MEM_SIZE shiftr; - -#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 + MEM_SIZE shiftr; + int bucket; + size_t nbytes = *nbytes_p; /* * Convert amount of memory requested into @@ -1448,6 +1446,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; + register union overhead *p; + register 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 = S_ajust_size_and_find_bucket(&nbytes); MALLOC_LOCK; /* * If nothing in hash bucket right now, @@ -1508,7 +1528,7 @@ Perl_malloc(register size_t nbytes) || (p->ov_next && PTR2UV(p->ov_next) < (1<ov_next), PTR2UV(p)); } @@ -1658,6 +1678,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; @@ -1666,9 +1687,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; @@ -1713,7 +1734,7 @@ 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 */ +#if !defined(atarist) /* 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. */ @@ -1722,7 +1743,7 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) add += slack; } # endif -#endif /* !atarist && !MINT */ +#endif /* !atarist */ if (add) { DEBUG_m(PerlIO_printf(Perl_debug_log, @@ -1797,7 +1818,7 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) # endif } #endif - ; /* Finish `else' */ + ; /* Finish "else" */ sbrked_remains = require - needed; last_op = cp; } @@ -1858,6 +1879,7 @@ getpages_adjacent(MEM_SIZE require) static void morecore(register int bucket) { + dVAR; register union overhead *ovp; register int rnu; /* 2^rnu bytes will be requested */ int nblks; /* become nblks blocks of the desired size */ @@ -1891,9 +1913,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; @@ -1990,11 +2012,12 @@ morecore(register int bucket) } Free_t -Perl_mfree(void *mp) +Perl_mfree(Malloc_t where) { + dVAR; register MEM_SIZE size; register union overhead *ovp; - char *cp = (char*)mp; + char *cp = (char*)where; #ifdef PACK_MALLOC u_char bucket; #endif @@ -2033,10 +2056,10 @@ Perl_mfree(void *mp) #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)", @@ -2046,8 +2069,8 @@ Perl_mfree(void *mp) #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"); @@ -2096,6 +2119,7 @@ Perl_mfree(void *mp) Malloc_t Perl_realloc(void *mp, size_t nbytes) { + dVAR; register MEM_SIZE onb; union overhead *ovp; char *res; @@ -2134,16 +2158,16 @@ 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", @@ -2154,15 +2178,15 @@ Perl_realloc(void *mp, size_t nbytes) #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); @@ -2271,6 +2295,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; @@ -2311,8 +2337,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 (char *)CopyD(s, s1, (MEM_SIZE)(l+1), char); } #ifdef PERL_CORE @@ -2335,7 +2360,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); @@ -2348,14 +2373,17 @@ 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); + + 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; } @@ -2363,6 +2391,13 @@ Perl_malloced_size(void *p) return BUCKET_SIZE_REAL(bucket); } + +MEM_SIZE +Perl_malloc_good_size(size_t wanted) +{ + return BUCKET_SIZE_REAL(S_ajust_size_and_find_bucket(&wanted)); +} + # ifdef BUCKETS_ROOT2 # define MIN_EVEN_REPORT 6 # else @@ -2377,6 +2412,8 @@ Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level) register 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; @@ -2417,6 +2454,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 */ } @@ -2428,7 +2467,7 @@ 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; @@ -2436,6 +2475,8 @@ Perl_dump_mstats(pTHX_ char *s) UV nf[NBUCKETS]; UV nt[NBUCKETS]; + PERL_ARGS_ASSERT_DUMP_MSTATS; + buffer.nfree = nf; buffer.ntotal = nt; get_mstats(&buffer, NBUCKETS, 0); @@ -2488,13 +2529,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(NeXT) || defined(__NeXT__) || defined(PURIFY) # define PERL_SBRK_VIA_MALLOC # endif @@ -2565,3 +2607,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: + */