X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=malloc.c;h=73c4039d8006db55401d73b2c1306cc7bc0c83f4;hb=01e4aa14c2f1b1acb8c9f4937a640ca107fbc0a6;hp=2cbdcfd13cac04f003c4384de94519e489f3dcb1;hpb=d720c4410d3a0730e373566db978e2b5789690e0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/malloc.c b/malloc.c index 2cbdcfd..73c4039 100644 --- a/malloc.c +++ b/malloc.c @@ -2,6 +2,115 @@ * */ +/* + Here are some notes on configuring Perl's malloc. + + There are two macros which serve as bulk disablers of advanced + features of this malloc: NO_FANCY_MALLOC, PLAIN_MALLOC (undef by + default). Look in the list of default values below to understand + their exact effect. Defining NO_FANCY_MALLOC returns malloc.c to the + state of the malloc in Perl 5.004. Additionally defining PLAIN_MALLOC + returns it to the state as of Perl 5.000. + + Note that some of the settings below may be ignored in the code based + on values of other macros. The PERL_CORE symbol is only defined when + perl itself is being compiled (so malloc can make some assumptions + about perl's facilities being available to it). + + Each config option has a short description, followed by its name, + default value, and a comment about the default (if applicable). Some + options take a precise value, while the others are just boolean. + The boolean ones are listed first. + + # Enable code for an emergency memory pool in $^M. See perlvar.pod + # for a description of $^M. + PERL_EMERGENCY_SBRK (!PLAIN_MALLOC && PERL_CORE) + + # Enable code for printing memory statistics. + DEBUGGING_MSTATS (!PLAIN_MALLOC && PERL_CORE) + + # Move allocation info for small buckets into separate areas. + # Memory optimization (especially for small allocations, of the + # less than 64 bytes). Since perl usually makes a large number + # of small allocations, this is usually a win. + PACK_MALLOC (!PLAIN_MALLOC && !RCHECK) + + # Add one page to big powers of two when calculating bucket size. + # This is targeted at big allocations, as are common in image + # processing. + TWO_POT_OPTIMIZE !PLAIN_MALLOC + + # Use intermediate bucket sizes between powers-of-two. This is + # generally a memory optimization, and a (small) speed pessimization. + BUCKETS_ROOT2 !NO_FANCY_MALLOC + + # Do not check small deallocations for bad free(). Memory + # and speed optimization, error reporting pessimization. + IGNORE_SMALL_BAD_FREE (!NO_FANCY_MALLOC && !RCHECK) + + # Use table lookup to decide in which bucket a given allocation will go. + SMALL_BUCKET_VIA_TABLE !NO_FANCY_MALLOC + + # Use a perl-defined sbrk() instead of the (presumably broken or + # missing) system-supplied sbrk(). + USE_PERL_SBRK undef + + # Use system malloc() (or calloc() etc.) to emulate sbrk(). Normally + # only used with broken sbrk()s. + PERL_SBRK_VIA_MALLOC undef + + # Which allocator to use if PERL_SBRK_VIA_MALLOC + SYSTEM_ALLOC(a) malloc(a) + + # Disable memory overwrite checking with DEBUGGING. Memory and speed + # optimization, error reporting pessimization. + NO_RCHECK undef + + # Enable memory overwrite checking with DEBUGGING. Memory and speed + # pessimization, error reporting optimization + RCHECK (DEBUGGING && !NO_RCHECK) + + # Failed allocations bigger than this size croak (if + # PERL_EMERGENCY_SBRK is enabled) without touching $^M. See + # perlvar.pod for a description of $^M. + BIG_SIZE (1<<16) # 64K + + # Starting from this power of two, add an extra page to the + # size of the bucket. This enables optimized allocations of sizes + # close to powers of 2. Note that the value is indexed at 0. + FIRST_BIG_POW2 15 # 32K, 16K is used too often + + # Estimate of minimal memory footprint. malloc uses this value to + # request the most reasonable largest blocks of memory from the system. + FIRST_SBRK (48*1024) + + # Round up sbrk()s to multiples of this. + MIN_SBRK 2048 + + # Round up sbrk()s to multiples of this percent of footprint. + MIN_SBRK_FRAC 3 + + # Add this much memory to big powers of two to get the bucket size. + PERL_PAGESIZE 4096 + + # This many sbrk() discontinuities should be tolerated even + # from the start without deciding that sbrk() is usually + # discontinuous. + SBRK_ALLOW_FAILURES 3 + + # This many continuous sbrk()s compensate for one discontinuous one. + SBRK_FAILURE_PRICE 50 + + # Some configurations may ask for 12-byte-or-so allocations which + # require 8-byte alignment (?!). In such situation one needs to + # define this to disable 12-byte bucket (will increase memory footprint) + STRICT_ALIGNMENT undef + + This implementation assumes that calling PerlIO_printf() does not + result in any memory allocation calls (used during a panic). + + */ + #ifndef NO_FANCY_MALLOC # ifndef SMALL_BUCKET_VIA_TABLE # define SMALL_BUCKET_VIA_TABLE @@ -121,7 +230,7 @@ #ifdef DEBUGGING # undef DEBUG_m -# define DEBUG_m(a) if (debug & 128) a +# define DEBUG_m(a) if (PL_debug & 128) a #endif /* I don't much care whether these are defined in sys/types.h--LAW */ @@ -177,6 +286,7 @@ static void botch _((char *diag, char *s)); #endif static void morecore _((int bucket)); static int findbucket _((union overhead *freep, int srchlen)); +static void add_to_chain(void *p, MEM_SIZE size, MEM_SIZE chip); #define MAGIC 0xff /* magic # on accounting info */ #define RMAGIC 0x55555555 /* magic # on range info */ @@ -207,6 +317,19 @@ static int findbucket _((union overhead *freep, int srchlen)); # define BUCKETS_PER_POW2 1 #endif +#if !defined(MEM_ALIGNBYTES) || ((MEM_ALIGNBYTES > 4) && !defined(STRICT_ALIGNMENT)) +/* Figure out the alignment of void*. */ +struct aligner { + char c; + void *p; +}; +# define ALIGN_SMALL ((int)((caddr_t)&(((struct aligner*)0)->p))) +#else +# define ALIGN_SMALL MEM_ALIGNBYTES +#endif + +#define IF_ALIGN_8(yes,no) ((ALIGN_SMALL>4) ? (yes) : (no)) + #ifdef BUCKETS_ROOT2 # define MAX_BUCKET_BY_TABLE 13 static u_short buck_size[MAX_BUCKET_BY_TABLE + 1] = @@ -351,7 +474,7 @@ static char bucket_of[] = /* 0 to 15 in 4-byte increments. */ (sizeof(void*) > 4 ? 6 : 5), /* 4/8, 5-th bucket for better reports */ 6, /* 8 */ - 7, 8, /* 12, 16 */ + IF_ALIGN_8(8,7), 8, /* 16/12, 16 */ 9, 9, 10, 10, /* 24, 32 */ 11, 11, 11, 11, /* 48 */ 12, 12, 12, 12, /* 64 */ @@ -454,46 +577,59 @@ static Malloc_t emergency_sbrk(size) MEM_SIZE size; { + MEM_SIZE rsize = (((size - 1)>>LOG_OF_MIN_ARENA) + 1)<= BIG_SIZE) { /* Give the possibility to recover: */ - MUTEX_UNLOCK(&malloc_mutex); - croak("Out of memory during request for %i bytes", size); + MUTEX_UNLOCK(&PL_malloc_mutex); + croak("Out of memory during \"large\" request for %i bytes", size); } - if (!emergency_buffer) { + if (emergency_buffer_size >= rsize) { + char *old = emergency_buffer; + + emergency_buffer_size -= rsize; + emergency_buffer += rsize; + return old; + } else { dTHR; /* First offense, give a possibility to recover by dieing. */ /* No malloc involved here: */ - GV **gvp = (GV**)hv_fetch(defstash, "^M", 2, 0); + GV **gvp = (GV**)hv_fetch(PL_defstash, "^M", 2, 0); SV *sv; char *pv; + int have = 0; - if (!gvp) gvp = (GV**)hv_fetch(defstash, "\015", 1, 0); + if (emergency_buffer_size) { + add_to_chain(emergency_buffer, emergency_buffer_size, 0); + emergency_buffer_size = 0; + emergency_buffer = Nullch; + have = 1; + } + if (!gvp) gvp = (GV**)hv_fetch(PL_defstash, "\015", 1, 0); if (!gvp || !(sv = GvSV(*gvp)) || !SvPOK(sv) - || (SvLEN(sv) < (1<= size) { - emergency_buffer_size -= size; - return emergency_buffer + emergency_buffer_size; + SvPVX(sv) = Nullch; + SvCUR(sv) = SvLEN(sv) = 0; } - - return (char *)-1; /* poor guy... */ + do_croak: + MUTEX_UNLOCK(&PL_malloc_mutex); + croak("Out of memory during request for %i bytes", size); } #else /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */ @@ -562,7 +698,7 @@ malloc(register size_t nbytes) croak("%s", "panic: malloc"); #endif - MUTEX_LOCK(&malloc_mutex); + MUTEX_LOCK(&PL_malloc_mutex); /* * Convert amount of memory requested into * closest block size stored in hash buckets @@ -601,9 +737,9 @@ malloc(register size_t nbytes) if (nextf[bucket] == NULL) morecore(bucket); if ((p = nextf[bucket]) == NULL) { - MUTEX_UNLOCK(&malloc_mutex); + MUTEX_UNLOCK(&PL_malloc_mutex); #ifdef PERL_CORE - if (!nomemok) { + if (!PL_nomemok) { PerlIO_puts(PerlIO_stderr(),"Out of memory!\n"); my_exit(1); } @@ -614,12 +750,12 @@ malloc(register size_t nbytes) DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05lu) malloc %ld bytes\n", - (unsigned long)(p+1), (unsigned long)(an++), + (unsigned long)(p+1), (unsigned long)(PL_an++), (long)size)); /* remove from linked list */ -#ifdef RCHECK - if (*((int*)p) & (sizeof(union overhead) - 1)) +#if defined(RCHECK) + if (((UV)p) & (MEM_ALIGNBYTES - 1)) PerlIO_printf(PerlIO_stderr(), "Corrupt malloc ptr 0x%lx at 0x%lx\n", (unsigned long)*((int*)p),(unsigned long)p); #endif @@ -651,7 +787,7 @@ malloc(register size_t nbytes) *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC; } #endif - MUTEX_UNLOCK(&malloc_mutex); + MUTEX_UNLOCK(&PL_malloc_mutex); return ((Malloc_t)(p + CHUNK_SHIFT)); } @@ -754,6 +890,190 @@ get_from_bigger_buckets(int bucket, MEM_SIZE size) return NULL; } +static union overhead * +getpages(int needed, int *nblksp, int bucket) +{ + /* Need to do (possibly expensive) system call. Try to + optimize it for rare calling. */ + MEM_SIZE require = needed - sbrked_remains; + char *cp; + union overhead *ovp; + int slack = 0; + + if (sbrk_good > 0) { + if (!last_sbrk_top && require < FIRST_SBRK) + require = FIRST_SBRK; + else if (require < MIN_SBRK) require = MIN_SBRK; + + if (require < goodsbrk * MIN_SBRK_FRAC / 100) + require = goodsbrk * MIN_SBRK_FRAC / 100; + require = ((require - 1 + MIN_SBRK) / MIN_SBRK) * MIN_SBRK; + } else { + require = needed; + last_sbrk_top = 0; + sbrked_remains = 0; + } + + DEBUG_m(PerlIO_printf(Perl_debug_log, + "sbrk(%ld) for %ld-byte-long arena\n", + (long)require, (long) needed)); + cp = (char *)sbrk(require); +#ifdef DEBUGGING_MSTATS + sbrks++; +#endif + if (cp == last_sbrk_top) { + /* Common case, anything is fine. */ + sbrk_good++; + ovp = (union overhead *) (cp - sbrked_remains); + sbrked_remains = require - (needed - sbrked_remains); + } else if (cp == (char *)-1) { /* no more room! */ + ovp = (union overhead *)emergency_sbrk(needed); + if (ovp == (union overhead *)-1) + return 0; + return ovp; + } else { /* Non-continuous or first sbrk(). */ + long add = sbrked_remains; + char *newcp; + + if (sbrked_remains) { /* Put rest into chain, we + cannot use it right now. */ + add_to_chain((void*)(last_sbrk_top - sbrked_remains), + sbrked_remains, 0); + } + + /* Second, check alignment. */ + slack = 0; + +#ifndef 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 */ + + /* CHUNK_SHIFT is 1 for PACK_MALLOC, 0 otherwise. */ + if ((UV)cp & (0x7FF >> CHUNK_SHIFT)) { /* Not aligned. */ + slack = (0x800 >> CHUNK_SHIFT) + - ((UV)cp & (0x7FF >> CHUNK_SHIFT)); + add += slack; + } +# endif +#endif /* atarist */ + + 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", + (long)add, (long) slack, + (long) sbrked_remains)); + newcp = (char *)sbrk(add); +#if defined(DEBUGGING_MSTATS) + sbrks++; + sbrk_slack += add; +#endif + if (newcp != cp + require) { + /* Too bad: even rounding sbrk() is not continuous.*/ + DEBUG_m(PerlIO_printf(Perl_debug_log, + "failed to fix bad sbrk()\n")); +#ifdef PACK_MALLOC + if (slack) { + MUTEX_UNLOCK(&PL_malloc_mutex); + croak("%s", "panic: Off-page sbrk"); + } +#endif + if (sbrked_remains) { + /* Try again. */ +#if defined(DEBUGGING_MSTATS) + sbrk_slack += require; +#endif + require = needed; + DEBUG_m(PerlIO_printf(Perl_debug_log, + "straight sbrk(%ld)\n", + (long)require)); + cp = (char *)sbrk(require); +#ifdef DEBUGGING_MSTATS + sbrks++; +#endif + if (cp == (char *)-1) + return 0; + } + sbrk_good = -1; /* Disable optimization! + Continue with not-aligned... */ + } else { + cp += slack; + require += sbrked_remains; + } + } + + if (last_sbrk_top) { + sbrk_good -= SBRK_FAILURE_PRICE; + } + + ovp = (union overhead *) cp; + /* + * Round up to minimum allocation size boundary + * and deduct from block count to reflect. + */ + +#ifndef I286 /* Again, this should always be ok on an 80286 */ + if ((UV)ovp & 7) { + ovp = (union overhead *)(((UV)ovp + 8) & ~7); + DEBUG_m(PerlIO_printf(Perl_debug_log, + "fixing sbrk(): %d bytes off machine alignement\n", + (int)((UV)ovp & 7))); + (*nblksp)--; +# if defined(DEBUGGING_MSTATS) + /* This is only approx. if TWO_POT_OPTIMIZE: */ + sbrk_slack += (1 << bucket); +# endif + } +#endif + sbrked_remains = require - needed; + } + last_sbrk_top = cp + require; + last_op = (char*) cp; +#ifdef DEBUGGING_MSTATS + goodsbrk += require; +#endif + return ovp; +} + +static int +getpages_adjacent(int require) +{ + if (require <= sbrked_remains) { + sbrked_remains -= require; + } else { + char *cp; + + require -= sbrked_remains; + /* We do not try to optimize sbrks here, we go for place. */ + cp = (char*) sbrk(require); +#ifdef DEBUGGING_MSTATS + sbrks++; + goodsbrk += require; +#endif + if (cp == last_sbrk_top) { + sbrked_remains = 0; + last_sbrk_top = cp + require; + } else { + if (cp == (char*)-1) { /* Out of memory */ +#ifdef DEBUGGING_MSTATS + goodsbrk -= require; +#endif + return 0; + } + /* Report the failure: */ + if (sbrked_remains) + add_to_chain((void*)(last_sbrk_top - sbrked_remains), + sbrked_remains, 0); + add_to_chain((void*)cp, require, 0); + sbrk_good -= SBRK_FAILURE_PRICE; + sbrked_remains = 0; + last_sbrk_top = 0; + last_op = 0; + return 0; + } + } + + return 1; +} + /* * Allocate more memory to the indicated bucket. */ @@ -762,14 +1082,13 @@ morecore(register int bucket) { register union overhead *ovp; register int rnu; /* 2^rnu bytes will be requested */ - register int nblks; /* become nblks blocks of the desired size */ + int nblks; /* become nblks blocks of the desired size */ register MEM_SIZE siz, needed; - int slack = 0; if (nextf[bucket]) return; if (bucket == sizeof(MEM_SIZE)*8*BUCKETS_PER_POW2) { - MUTEX_UNLOCK(&malloc_mutex); + MUTEX_UNLOCK(&PL_malloc_mutex); croak("%s", "Out of memory during ridiculously large request"); } if (bucket > max_bucket) @@ -807,145 +1126,12 @@ morecore(register int bucket) ovp = (union overhead *)(last_sbrk_top - sbrked_remains); sbrked_remains -= needed; last_op = (char*)ovp; - } else { - /* Need to do (possibly expensive) system call. Try to - optimize it for rare calling. */ - MEM_SIZE require = needed - sbrked_remains; - char *cp; - - if (sbrk_good > 0) { - if (!last_sbrk_top && require < FIRST_SBRK) - require = FIRST_SBRK; - else if (require < MIN_SBRK) require = MIN_SBRK; - - if (require < goodsbrk * MIN_SBRK_FRAC / 100) - require = goodsbrk * MIN_SBRK_FRAC / 100; - require = ((require - 1 + MIN_SBRK) / MIN_SBRK) * MIN_SBRK; - } else { - require = needed; - last_sbrk_top = 0; - sbrked_remains = 0; - } - - DEBUG_m(PerlIO_printf(Perl_debug_log, - "sbrk(%ld) for %ld-byte-long arena\n", - (long)require, (long) needed)); - cp = (char *)sbrk(require); -#ifdef DEBUGGING_MSTATS - sbrks++; -#endif - if (cp == last_sbrk_top) { - /* Common case, anything is fine. */ - sbrk_good++; - ovp = (union overhead *) (cp - sbrked_remains); - sbrked_remains = require - (needed - sbrked_remains); - } else if (cp == (char *)-1) { /* no more room! */ - ovp = (union overhead *)emergency_sbrk(needed); - if (ovp == (union overhead *)-1) - return; - goto gotit; - } else { /* Non-continuous or first sbrk(). */ - long add = sbrked_remains; - char *newcp; - - if (sbrked_remains) { /* Put rest into chain, we - cannot use it right now. */ - add_to_chain((void*)(last_sbrk_top - sbrked_remains), - sbrked_remains, 0); - } - - /* Second, check alignment. */ - slack = 0; + } else + ovp = getpages(needed, &nblks, bucket); -#ifndef 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 */ + if (!ovp) + return; - /* CHUNK_SHIFT is 1 for PACK_MALLOC, 0 otherwise. */ - if ((UV)cp & (0x7FF >> CHUNK_SHIFT)) { /* Not aligned. */ - slack = (0x800 >> CHUNK_SHIFT) - - ((UV)cp & (0x7FF >> CHUNK_SHIFT)); - add += slack; - } -# endif -#endif /* atarist */ - - 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", - (long)add, (long) slack, - (long) sbrked_remains)); - newcp = (char *)sbrk(add); -#if defined(DEBUGGING_MSTATS) - sbrks++; - sbrk_slack += add; -#endif - if (newcp != cp + require) { - /* Too bad: even rounding sbrk() is not continuous.*/ - DEBUG_m(PerlIO_printf(Perl_debug_log, - "failed to fix bad sbrk()\n")); -#ifdef PACK_MALLOC - if (slack) { - MUTEX_UNLOCK(&malloc_mutex); - croak("%s", "panic: Off-page sbrk"); - } -#endif - if (sbrked_remains) { - /* Try again. */ -#if defined(DEBUGGING_MSTATS) - sbrk_slack += require; -#endif - require = needed; - DEBUG_m(PerlIO_printf(Perl_debug_log, - "straight sbrk(%ld)\n", - (long)require)); - cp = (char *)sbrk(require); -#ifdef DEBUGGING_MSTATS - sbrks++; -#endif - if (cp == (char *)-1) - return; - } - sbrk_good = -1; /* Disable optimization! - Continue with not-aligned... */ - } else { - cp += slack; - require += sbrked_remains; - } - } - - if (last_sbrk_top) { - sbrk_good -= SBRK_FAILURE_PRICE; - } - - ovp = (union overhead *) cp; - /* - * Round up to minimum allocation size boundary - * and deduct from block count to reflect. - */ - -#ifndef I286 /* Again, this should always be ok on an 80286 */ - if ((UV)ovp & 7) { - ovp = (union overhead *)(((UV)ovp + 8) & ~7); - DEBUG_m(PerlIO_printf(Perl_debug_log, - "fixing sbrk(): %d bytes off machine alignement\n", - (int)((UV)ovp & 7))); - nblks--; -# if defined(DEBUGGING_MSTATS) - /* This is only approx. if TWO_POT_OPTIMIZE: */ - sbrk_slack += (1 << bucket); -# endif - } -#endif - sbrked_remains = require - needed; - } - last_sbrk_top = cp + require; - last_op = (char*) cp; -#ifdef DEBUGGING_MSTATS - goodsbrk += require; -#endif - } - - gotit: /* * Add new memory allocated to that on * free list for this hash bucket. @@ -1000,7 +1186,7 @@ free(void *mp) DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05lu) free\n", - (unsigned long)cp, (unsigned long)(an++))); + (unsigned long)cp, (unsigned long)(PL_an++))); if (cp == NULL) return; @@ -1031,7 +1217,7 @@ free(void *mp) #endif return; /* sanity */ } - MUTEX_LOCK(&malloc_mutex); + MUTEX_LOCK(&PL_malloc_mutex); #ifdef RCHECK ASSERT(ovp->ov_rmagic == RMAGIC, "chunk's head overwrite"); if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) { @@ -1054,7 +1240,7 @@ free(void *mp) size = OV_INDEX(ovp); ovp->ov_next = nextf[size]; nextf[size] = ovp; - MUTEX_UNLOCK(&malloc_mutex); + MUTEX_UNLOCK(&PL_malloc_mutex); } /* @@ -1092,7 +1278,7 @@ realloc(void *mp, size_t nbytes) if (!cp) return malloc(nbytes); - MUTEX_LOCK(&malloc_mutex); + MUTEX_LOCK(&PL_malloc_mutex); ovp = (union overhead *)((caddr_t)cp - sizeof (union overhead) * CHUNK_SHIFT); bucket = OV_INDEX(ovp); @@ -1190,7 +1376,11 @@ realloc(void *mp, size_t nbytes) } #endif res = cp; - MUTEX_UNLOCK(&malloc_mutex); + MUTEX_UNLOCK(&PL_malloc_mutex); + DEBUG_m(PerlIO_printf(Perl_debug_log, + "0x%lx: (%05lu) realloc %ld bytes inplace\n", + (unsigned long)res,(unsigned long)(PL_an++), + (long)size)); } else if (incr == 1 && (cp - M_OVERHEAD == last_op) && (onb > (1 << LOG_OF_MIN_ARENA))) { MEM_SIZE require, newarena = nbytes, pow; @@ -1207,44 +1397,22 @@ realloc(void *mp, size_t nbytes) newarena = (1 << pow) + POW2_OPTIMIZE_SURPLUS(pow * BUCKETS_PER_POW2); require = newarena - onb - M_OVERHEAD; - if (require <= sbrked_remains) { - sbrked_remains -= require; - } else { - char *cp; - - require -= sbrked_remains; - /* We do not try to optimize sbrks here, we go for place. */ - cp = (char*) sbrk(require); -#ifdef DEBUGGING_MSTATS - sbrks++; - goodsbrk += require; -#endif - if (cp == last_sbrk_top) { - sbrked_remains = 0; - last_sbrk_top = cp + require; - } else { - /* Report the failure: */ - if (sbrked_remains) - add_to_chain((void*)(last_sbrk_top - sbrked_remains), - sbrked_remains, 0); - add_to_chain((void*)cp, require, 0); - sbrk_good -= SBRK_FAILURE_PRICE; - sbrked_remains = 0; - last_sbrk_top = 0; - last_op = 0; - goto hard_way; - } - } - + if (getpages_adjacent(require)) { #ifdef DEBUGGING_MSTATS - nmalloc[bucket]--; - nmalloc[pow * BUCKETS_PER_POW2]++; + nmalloc[bucket]--; + nmalloc[pow * BUCKETS_PER_POW2]++; #endif - *(cp - M_OVERHEAD) = pow * BUCKETS_PER_POW2; /* Fill index. */ - goto inplace_label; + *(cp - M_OVERHEAD) = pow * BUCKETS_PER_POW2; /* Fill index. */ + goto inplace_label; + } else + goto hard_way; } else { hard_way: - MUTEX_UNLOCK(&malloc_mutex); + MUTEX_UNLOCK(&PL_malloc_mutex); + DEBUG_m(PerlIO_printf(Perl_debug_log, + "0x%lx: (%05lu) realloc %ld bytes the hard way\n", + (unsigned long)cp,(unsigned long)(PL_an++), + (long)size)); if ((res = (char*)malloc(nbytes)) == NULL) return (NULL); if (cp != res) /* common optimization */ @@ -1252,13 +1420,6 @@ realloc(void *mp, size_t nbytes) if (was_alloced) free(cp); } - - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lu: (%05lu) rfree\n", - (unsigned long)res,(unsigned long)(an++))); - DEBUG_m(PerlIO_printf(Perl_debug_log, - "0x%lx: (%05lu) realloc %ld bytes\n", - (unsigned long)res,(unsigned long)(an++), - (long)size)); return ((Malloc_t)res); } @@ -1299,8 +1460,18 @@ calloc(register size_t elements, register size_t size) MEM_SIZE malloced_size(void *p) { - int bucket = OV_INDEX((union overhead *)p); - + union overhead *ovp = (union overhead *) + ((caddr_t)p - sizeof (union overhead) * CHUNK_SHIFT); + 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); + ovp->ov_size = size + M_OVERHEAD - 1; + *((u_int *)((caddr_t)ovp + size + M_OVERHEAD - RSLOP)) = RMAGIC; + } +#endif return BUCKET_SIZE_REAL(bucket); } @@ -1405,9 +1576,27 @@ dump_mstats(char *s) # define PERL_SBRK_VIA_MALLOC # endif +# ifdef __MACHTEN_PPC__ +# define PERL_SBRK_VIA_MALLOC +/* + * MachTen's malloc() returns a buffer aligned on a two-byte boundary. + * While this is adequate, it may slow down access to longer data + * types by forcing multiple memory accesses. It also causes + * complaints when RCHECK is in force. So we allocate six bytes + * more than we need to, and return an address rounded up to an + * eight-byte boundary. + * + * 980701 Dominic Dunlop + */ +# define SYSTEM_ALLOC(a) ((void *)(((unsigned)malloc((a)+6)+6)&~7)) +# endif + # ifdef PERL_SBRK_VIA_MALLOC # if defined(HIDEMYMALLOC) || defined(EMBEDMYMALLOC) -# undef malloc +# undef malloc /* Expose names that */ +# undef calloc /* HIDEMYMALLOC hides */ +# undef realloc +# undef free # else # include "Error: -DPERL_SBRK_VIA_MALLOC needs -D(HIDE|EMBED)MYMALLOC" # endif @@ -1417,7 +1606,9 @@ dump_mstats(char *s) /* frequent core dumps within nxzonefreenolock. This sbrk routine put an */ /* end to the cores */ -# define SYSTEM_ALLOC(a) malloc(a) +# ifndef SYSTEM_ALLOC +# define SYSTEM_ALLOC(a) malloc(a) +# endif # endif /* PERL_SBRK_VIA_MALLOC */