X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d0bbed784b85a44e92a8a0e3d4046ce7f236db02..88c9ea1eee075fb55dd1fa8e866125da26b560ff:/malloc.c?ds=sidebyside diff --git a/malloc.c b/malloc.c index e3c1449..ce406d2 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 { /* @@ -631,7 +640,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, }; @@ -795,7 +804,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 +827,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 +875,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. */ @@ -1065,6 +1074,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 +1102,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,14 +1136,13 @@ 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 @@ -1139,17 +1156,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; @@ -1231,7 +1249,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; } @@ -1258,7 +1276,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) */ @@ -1273,16 +1291,18 @@ write2(char *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) { + dVAR; 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 ("); @@ -1318,7 +1338,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 +1379,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)); @@ -1390,6 +1410,7 @@ cmp_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill) Malloc_t Perl_malloc(register size_t nbytes) { + dVAR; register union overhead *p; register int bucket; register MEM_SIZE shiftr; @@ -1497,7 +1518,7 @@ Perl_malloc(register size_t nbytes) || (p->ov_next && PTR2UV(p->ov_next) < (1<ov_next), PTR2UV(p)); } @@ -1647,6 +1668,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,9 +1677,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; @@ -1786,7 +1808,7 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) # endif } #endif - ; /* Finish `else' */ + ; /* Finish "else" */ sbrked_remains = require - needed; last_op = cp; } @@ -1847,6 +1869,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 */ @@ -1880,9 +1903,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; @@ -1979,11 +2002,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 @@ -2085,6 +2109,7 @@ Perl_mfree(void *mp) Malloc_t Perl_realloc(void *mp, size_t nbytes) { + dVAR; register MEM_SIZE onb; union overhead *ovp; char *res; @@ -2123,7 +2148,7 @@ 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 { @@ -2151,7 +2176,7 @@ Perl_realloc(void *mp, size_t nbytes) warn("%s", "Bad realloc() ignored"); #endif #endif - return Nullch; /* sanity */ + return NULL; /* sanity */ } onb = BUCKET_SIZE_REAL(bucket); @@ -2300,8 +2325,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 @@ -2324,7 +2348,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); @@ -2337,14 +2361,14 @@ 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 - RMAGIC_SZ)) = RMAGIC; } @@ -2479,7 +2503,6 @@ Perl_dump_mstats(pTHX_ char *s) buffer.total_chain, buffer.sbrked_remains); #endif /* DEBUGGING_MSTATS */ } -#endif /* lint */ #ifdef USE_PERL_SBRK @@ -2554,3 +2577,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: + */