perl
view release on metacpan or search on metacpan
/* We postpone stealing from bigger buckets until we want it
often enough. */
if (nextf[bucket] && bucketprice[bucket]++ >= price) {
/* Steal it! */
void *ret = (void*)(nextf[bucket] - 1 + CHUNK_SHIFT);
bucketprice[bucket] = 0;
if (((char*)nextf[bucket]) - M_OVERHEAD == last_op) {
last_op = NULL; /* Disable optimization */
}
nextf[bucket] = nextf[bucket]->ov_next;
#ifdef DEBUGGING_MSTATS
nmalloc[bucket]--;
start_slack -= M_OVERHEAD;
#endif
add_to_chain(ret, (BUCKET_SIZE_NO_SURPLUS(bucket) +
POW2_OPTIMIZE_SURPLUS(bucket)),
size);
return ret;
}
bucket++;
}
return NULL;
}
static union overhead *
getpages(MEM_SIZE 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;
MEM_SIZE slack = 0;
if (sbrk_goodness > 0) {
if (!last_sbrk_top && require < (MEM_SIZE)FIRST_SBRK)
require = FIRST_SBRK;
else if (require < (MEM_SIZE)MIN_SBRK) require = MIN_SBRK;
if (require < (Size_t)(goodsbrk * MIN_SBRK_FRAC1000 / 1000))
require = goodsbrk * MIN_SBRK_FRAC1000 / 1000;
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_goodness++;
ovp = (union overhead *) (cp - sbrked_remains);
last_op = 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;
if (((char*)ovp) > last_op) { /* Cannot happen with current emergency_sbrk() */
last_op = 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;
/* WANTED_ALIGNMENT may be more than NEEDED_ALIGNMENT, but this may
improve performance of memory access. */
if (PTR2UV(cp) & (WANTED_ALIGNMENT - 1)) { /* Not aligned. */
slack = WANTED_ALIGNMENT - (PTR2UV(cp) & (WANTED_ALIGNMENT - 1));
add += slack;
}
if (add) {
DEBUG_m(PerlIO_printf(Perl_debug_log,
"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);
#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) {
MALLOC_UNLOCK;
fatalcroak("panic: Off-page sbrk\n");
}
#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_goodness = -1; /* Disable optimization!
Continue with not-aligned... */
} else {
cp += slack;
require += sbrked_remains;
}
}
if (last_sbrk_top) {
sbrk_goodness -= SBRK_FAILURE_PRICE;
}
ovp = (union overhead *) cp;
/*
* Round up to minimum allocation size boundary
* and deduct from block count to reflect.
*/
# if NEEDED_ALIGNMENT > MEM_ALIGNBYTES
if (PTR2UV(ovp) & (NEEDED_ALIGNMENT - 1))
fatalcroak("Misalignment of sbrk()\n");
else
# endif
if (PTR2UV(ovp) & (MEM_ALIGNBYTES - 1)) {
DEBUG_m(PerlIO_printf(Perl_debug_log,
"fixing sbrk(): %d bytes off machine alignment\n",
(int)(PTR2UV(ovp) & (MEM_ALIGNBYTES - 1))));
ovp = INT2PTR(union overhead *,(PTR2UV(ovp) + MEM_ALIGNBYTES) &
(MEM_ALIGNBYTES - 1));
(*nblksp)--;
# if defined(DEBUGGING_MSTATS)
/* This is only approx. if TWO_POT_OPTIMIZE: */
sbrk_slack += (1 << (bucket >> BUCKET_POW2_SHIFT));
# endif
}
; /* Finish "else" */
sbrked_remains = require - needed;
last_op = cp;
}
#if !defined(PLAIN_MALLOC) && !defined(NO_FANCY_MALLOC)
emergency_buffer_last_req = 0;
#endif
last_sbrk_top = cp + require;
#ifdef DEBUGGING_MSTATS
goodsbrk += require;
#endif
return ovp;
}
static int
getpages_adjacent(MEM_SIZE 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_goodness -= SBRK_FAILURE_PRICE;
sbrked_remains = 0;
last_sbrk_top = 0;
last_op = 0;
return 0;
}
}
return 1;
}
/*
* Allocate more memory to the indicated bucket.
*/
static void
morecore(int bucket)
{
union overhead *ovp;
int rnu; /* 2^rnu bytes will be requested */
int nblks; /* become nblks blocks of the desired size */
MEM_SIZE siz, needed;
static int were_called = 0;
if (nextf[bucket])
return;
#ifndef NO_PERL_MALLOC_ENV
if (!were_called) {
/* 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;
const char *off;
const char *opts = PERL_MALLOC_OPT_CHARS;
int changed = 0;
while ( t && t[0] && t[1] == '='
&& ((off = strchr(opts, *t))) ) {
IV val = 0;
t += 2;
while (isDIGIT(*t))
val = 10*val + *t++ - '0';
if (!*t || *t == ';') {
if (MallocCfg[off - opts] != val)
changed = 1;
MallocCfg[off - opts] = val;
if (*t)
t++;
}
}
if (t && *t) {
dTHX;
( run in 0.569 second using v1.01-cache-2.11-cpan-39bf76dae61 )