X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=malloc.c;h=7234801105c9207407fa4102ea66494382583aaf;hb=e505b8249ffa50fff52b65da8e9069b8fc1bdee8;hp=63f663067814b3f72fe3820f4555f6da4bca421c;hpb=a4fc7abc9c5502fa20253f620ede1e956c44caed;p=p5sagit%2Fp5-mst-13.2.git diff --git a/malloc.c b/malloc.c index 63f6630..7234801 100644 --- a/malloc.c +++ b/malloc.c @@ -3,7 +3,9 @@ */ /* - * "'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. @@ -379,9 +381,6 @@ # ifndef UVxf # define UVxf "lx" # endif -# ifndef Nullch -# define Nullch NULL -# endif # ifndef MEM_ALIGNBYTES # define MEM_ALIGNBYTES 4 # endif @@ -973,7 +972,7 @@ static const 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); @@ -1173,7 +1172,7 @@ perl_get_emergency_buffer(IV *size) } SvPOK_off(sv); - SvPV_set(sv, Nullch); + SvPV_set(sv, NULL); SvCUR_set(sv, 0); SvLEN_set(sv, 0); *size = malloced_size(pv) + M_OVERHEAD; @@ -1249,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; } @@ -1276,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) */ @@ -1284,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) { @@ -1405,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 @@ -1455,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, @@ -1665,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; @@ -1865,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 */ @@ -1997,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 @@ -2103,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; @@ -2141,7 +2158,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 { @@ -2169,7 +2186,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); @@ -2278,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; @@ -2318,7 +2337,7 @@ Perl_strdup(const char *s) MEM_SIZE l = strlen(s); char *s1 = (char *)Perl_malloc(l+1); - return CopyD(s, s1, (MEM_SIZE)(l+1), char); + return (char *)CopyD(s, s1, (MEM_SIZE)(l+1), char); } #ifdef PERL_CORE @@ -2341,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); @@ -2357,6 +2376,9 @@ Perl_malloced_size(void *p) union overhead * const ovp = (union overhead *) ((caddr_t)p - sizeof (union overhead) * CHUNK_SHIFT); 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. */ @@ -2369,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 @@ -2383,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; @@ -2423,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 */ } @@ -2434,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; @@ -2442,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); @@ -2494,6 +2529,8 @@ 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 */ }