summaryrefslogtreecommitdiff
path: root/gnu/usr.bin/perl/malloc.c
diff options
context:
space:
mode:
authorTodd C. Miller <millert@cvs.openbsd.org>2003-12-03 03:02:54 +0000
committerTodd C. Miller <millert@cvs.openbsd.org>2003-12-03 03:02:54 +0000
commitba0a2090f574df90404f8a0bbe689389ce0ebcab (patch)
tree53f8d0ad53e5fc0f05d68a0073273080ef5bd392 /gnu/usr.bin/perl/malloc.c
parent0121b80e4f69c2ad9631e8d20b5c91f3b2a40434 (diff)
Resolve conflicts for perl 5.8.2, remove old files, and add OpenBSD-specific scaffolding
Diffstat (limited to 'gnu/usr.bin/perl/malloc.c')
-rw-r--r--gnu/usr.bin/perl/malloc.c637
1 files changed, 543 insertions, 94 deletions
diff --git a/gnu/usr.bin/perl/malloc.c b/gnu/usr.bin/perl/malloc.c
index 00c387ed6c6..6013e400837 100644
--- a/gnu/usr.bin/perl/malloc.c
+++ b/gnu/usr.bin/perl/malloc.c
@@ -27,9 +27,12 @@
options take a precise value, while the others are just boolean.
The boolean ones are listed first.
+ # Read configuration settings from malloc_cfg.h
+ HAVE_MALLOC_CFG_H undef
+
# Enable code for an emergency memory pool in $^M. See perlvar.pod
# for a description of $^M.
- PERL_EMERGENCY_SBRK (!PLAIN_MALLOC && PERL_CORE)
+ PERL_EMERGENCY_SBRK (!PLAIN_MALLOC && (PERL_CORE || !NO_MALLOC_DYNAMIC_CFG))
# Enable code for printing memory statistics.
DEBUGGING_MSTATS (!PLAIN_MALLOC && PERL_CORE)
@@ -78,6 +81,22 @@
# pessimization, error reporting optimization
RCHECK (DEBUGGING && !NO_RCHECK)
+ # Do not overwrite uninit areas with DEBUGGING. Speed
+ # optimization, error reporting pessimization
+ NO_MFILL undef
+
+ # Overwrite uninit areas with DEBUGGING. Speed
+ # pessimization, error reporting optimization
+ MALLOC_FILL (DEBUGGING && !NO_RCHECK && !NO_MFILL)
+
+ # Do not check overwritten uninit areas with DEBUGGING. Speed
+ # optimization, error reporting pessimization
+ NO_FILL_CHECK undef
+
+ # Check overwritten uninit areas with DEBUGGING. Speed
+ # pessimization, error reporting optimization
+ MALLOC_FILL_CHECK (DEBUGGING && !NO_RCHECK && !NO_FILL_CHECK)
+
# Failed allocations bigger than this size croak (if
# PERL_EMERGENCY_SBRK is enabled) without touching $^M. See
# perlvar.pod for a description of $^M.
@@ -98,6 +117,9 @@
# Round up sbrk()s to multiples of this percent of footprint.
MIN_SBRK_FRAC 3
+ # Round up sbrk()s to multiples of this multiple of 1/1000 of footprint.
+ MIN_SBRK_FRAC1000 (10 * MIN_SBRK_FRAC)
+
# Add this much memory to big powers of two to get the bucket size.
PERL_PAGESIZE 4096
@@ -114,6 +136,20 @@
# define this to disable 12-byte bucket (will increase memory footprint)
STRICT_ALIGNMENT undef
+ # Do not allow configuration of runtime options at runtime
+ NO_MALLOC_DYNAMIC_CFG undef
+
+ # Do not allow configuration of runtime options via $ENV{PERL_MALLOC_OPT}
+ NO_PERL_MALLOC_ENV undef
+
+ [The variable consists of ;-separated parts of the form CODE=VALUE
+ with 1-character codes F, M, f, A, P, G, d, a, c for runtime
+ configuration of FIRST_SBRK, MIN_SBRK, MIN_SBRK_FRAC1000,
+ SBRK_ALLOW_FAILURES, SBRK_FAILURE_PRICE, sbrk_goodness,
+ filldead, fillalive, fillcheck. The last 3 are for DEBUGGING
+ build, and allow switching the tests for free()ed memory read,
+ uninit memory reads, and free()ed memory write.]
+
This implementation assumes that calling PerlIO_printf() does not
result in any memory allocation calls (used during a panic).
@@ -138,12 +174,30 @@
# Unsigned integer type big enough to keep a pointer
UV unsigned long
+ # Signed integer of the same sizeof() as UV
+ IV long
+
# Type of pointer with 1-byte granularity
caddr_t char *
# Type returned by free()
Free_t void
+ # Conversion of pointer to integer
+ PTR2UV(ptr) ((UV)(ptr))
+
+ # Conversion of integer to pointer
+ INT2PTR(type, i) ((type)(i))
+
+ # printf()-%-Conversion of UV to pointer
+ UVuf "lu"
+
+ # printf()-%-Conversion of UV to hex pointer
+ UVxf "lx"
+
+ # Alignment to use
+ MEM_ALIGNBYTES 4
+
# Very fatal condition reporting function (cannot call any )
fatalcroak(arg) write(2,arg,strlen(arg)) + exit(2)
@@ -168,6 +222,10 @@
MUTEX_UNLOCK(l) void
*/
+#ifdef HAVE_MALLOC_CFG_H
+# include "malloc_cfg.h"
+#endif
+
#ifndef NO_FANCY_MALLOC
# ifndef SMALL_BUCKET_VIA_TABLE
# define SMALL_BUCKET_VIA_TABLE
@@ -187,7 +245,7 @@
# ifndef TWO_POT_OPTIMIZE
# define TWO_POT_OPTIMIZE
# endif
-# if defined(PERL_CORE) && !defined(PERL_EMERGENCY_SBRK)
+# if (defined(PERL_CORE) || !defined(NO_MALLOC_DYNAMIC_CFG)) && !defined(PERL_EMERGENCY_SBRK)
# define PERL_EMERGENCY_SBRK
# endif
# if defined(PERL_CORE) && !defined(DEBUGGING_MSTATS)
@@ -211,6 +269,12 @@
# 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
@@ -251,6 +315,11 @@
# define croak2 croak
# define warn2 warn
# endif
+# if defined(USE_5005THREADS) || defined(USE_ITHREADS)
+# define PERL_MAYBE_ALIVE PL_thr_key
+# else
+# define PERL_MAYBE_ALIVE 1
+# endif
#else
# ifdef PERL_FOR_X2P
# include "../EXTERN.h"
@@ -259,6 +328,10 @@
# include <stdlib.h>
# include <stdio.h>
# include <memory.h>
+# ifdef OS2
+# include <io.h>
+# endif
+# include <string.h>
# ifndef Malloc_t
# define Malloc_t void *
# endif
@@ -274,6 +347,9 @@
# ifndef UV
# define UV unsigned long
# endif
+# ifndef IV
+# define IV long
+# endif
# ifndef caddr_t
# define caddr_t char *
# endif
@@ -284,6 +360,25 @@
# define PerlEnv_getenv getenv
# define PerlIO_printf fprintf
# define PerlIO_stderr() stderr
+# define PerlIO_puts(f,s) fputs(s,f)
+# ifndef INT2PTR
+# define INT2PTR(t,i) ((t)(i))
+# endif
+# ifndef PTR2UV
+# define PTR2UV(p) ((UV)(p))
+# endif
+# ifndef UVuf
+# define UVuf "lu"
+# endif
+# ifndef UVxf
+# define UVxf "lx"
+# endif
+# ifndef Nullch
+# define Nullch NULL
+# endif
+# ifndef MEM_ALIGNBYTES
+# define MEM_ALIGNBYTES 4
+# endif
# endif
# ifndef croak /* make depend */
# define croak(mess, arg) (warn((mess), (arg)), exit(1))
@@ -295,7 +390,7 @@
# define warn(mess, arg) fprintf(stderr, (mess), (arg))
# endif
# ifndef warn2
-# define warn2(mess, arg1) fprintf(stderr, (mess), (arg1), (arg2))
+# define warn2(mess, arg1, arg2) fprintf(stderr, (mess), (arg1), (arg2))
# endif
# ifdef DEBUG_m
# undef DEBUG_m
@@ -317,6 +412,7 @@
# ifndef PERL_GET_INTERP
# define PERL_GET_INTERP PL_curinterp
# endif
+# define PERL_MAYBE_ALIVE 1
# ifndef Perl_malloc
# define Perl_malloc malloc
# endif
@@ -332,7 +428,7 @@
# ifndef Perl_strdup
# define Perl_strdup strdup
# endif
-#endif
+#endif /* defined PERL_CORE */
#ifndef MUTEX_LOCK
# define MUTEX_LOCK(l)
@@ -358,7 +454,7 @@
# undef DEBUG_m
# define DEBUG_m(a) \
STMT_START { \
- if (PERL_GET_INTERP) { \
+ if (PERL_MAYBE_ALIVE && PERL_GET_THX) { \
dTHX; \
if (DEBUG_m_TEST) { \
PL_debug &= ~DEBUG_m_FLAG; \
@@ -470,6 +566,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 {
/*
@@ -480,7 +579,8 @@ union overhead {
u_char ovu_index; /* bucket # */
u_char ovu_magic; /* magic number */
#ifdef RCHECK
- u_short ovu_size; /* actual block size */
+ /* Subtract one to fit into u_short for an extra bucket */
+ u_short ovu_size; /* block size (requested + overhead - 1) */
u_int ovu_rmagic; /* range magic number */
#endif
} ovu;
@@ -495,14 +595,14 @@ union overhead {
#define RMAGIC_C 0x55 /* magic # on range info */
#ifdef RCHECK
-# define RSLOP sizeof (u_int)
+# define RMAGIC_SZ sizeof (u_int) /* Overhead at end of bucket */
# ifdef TWO_POT_OPTIMIZE
-# define MAX_SHORT_BUCKET (12 * BUCKETS_PER_POW2)
+# define MAX_SHORT_BUCKET (12 * BUCKETS_PER_POW2) /* size-1 fits in short */
# else
# define MAX_SHORT_BUCKET (13 * BUCKETS_PER_POW2)
# endif
#else
-# define RSLOP 0
+# define RMAGIC_SZ 0
#endif
#if !defined(PACK_MALLOC) && defined(BUCKETS_ROOT2)
@@ -538,15 +638,16 @@ static u_short buck_size[MAX_BUCKET_BY_TABLE + 1] =
{
0, 0, 0, 0, 4, 4, 8, 12, 16, 24, 32, 48, 64, 80,
};
-# define BUCKET_SIZE(i) ((i) % 2 ? buck_size[i] : (1 << ((i) >> BUCKET_POW2_SHIFT)))
+# define BUCKET_SIZE_NO_SURPLUS(i) ((i) % 2 ? buck_size[i] : (1 << ((i) >> BUCKET_POW2_SHIFT)))
# define BUCKET_SIZE_REAL(i) ((i) <= MAX_BUCKET_BY_TABLE \
? buck_size[i] \
: ((1 << ((i) >> BUCKET_POW2_SHIFT)) \
- MEM_OVERHEAD(i) \
+ POW2_OPTIMIZE_SURPLUS(i)))
#else
-# define BUCKET_SIZE(i) (1 << ((i) >> BUCKET_POW2_SHIFT))
-# define BUCKET_SIZE_REAL(i) (BUCKET_SIZE(i) - MEM_OVERHEAD(i) + POW2_OPTIMIZE_SURPLUS(i))
+# define BUCKET_SIZE_NO_SURPLUS(i) (1 << ((i) >> BUCKET_POW2_SHIFT))
+# define BUCKET_SIZE(i) (BUCKET_SIZE_NO_SURPLUS(i) + POW2_OPTIMIZE_SURPLUS(i))
+# define BUCKET_SIZE_REAL(i) (BUCKET_SIZE(i) - MEM_OVERHEAD(i))
#endif
@@ -691,7 +792,7 @@ static u_short buck_size[MAX_BUCKET_BY_TABLE + 1] =
#ifdef IGNORE_SMALL_BAD_FREE
#define FIRST_BUCKET_WITH_CHECK (6 * BUCKETS_PER_POW2) /* 64 */
# define N_BLKS(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK \
- ? ((1<<LOG_OF_MIN_ARENA) - 1)/BUCKET_SIZE(bucket) \
+ ? ((1<<LOG_OF_MIN_ARENA) - 1)/BUCKET_SIZE_NO_SURPLUS(bucket) \
: n_blks[bucket] )
#else
# define N_BLKS(bucket) n_blks[bucket]
@@ -714,7 +815,7 @@ static u_short n_blks[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] =
#ifdef IGNORE_SMALL_BAD_FREE
# define BLK_SHIFT(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK \
? ((1<<LOG_OF_MIN_ARENA) \
- - BUCKET_SIZE(bucket) * N_BLKS(bucket)) \
+ - BUCKET_SIZE_NO_SURPLUS(bucket) * N_BLKS(bucket)) \
: blk_shift[bucket])
#else
# define BLK_SHIFT(bucket) blk_shift[bucket]
@@ -755,7 +856,7 @@ static u_short blk_shift[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] =
#endif /* !PACK_MALLOC */
-#define M_OVERHEAD (sizeof(union overhead) + RSLOP)
+#define M_OVERHEAD (sizeof(union overhead) + RMAGIC_SZ) /* overhead at start+end */
#ifdef PACK_MALLOC
# define MEM_OVERHEAD(bucket) \
@@ -866,7 +967,7 @@ static char bucket_of[] =
static void morecore (register int bucket);
# if defined(DEBUGGING)
-static void botch (char *diag, char *s);
+static void botch (char *diag, char *s, 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);
@@ -883,6 +984,12 @@ static int getpages_adjacent(MEM_SIZE require);
# define MUTEX_UNLOCK(m) STMT_START { if (*m) mutex_unlock(*m); } STMT_END
#endif
+#endif /* defined PERL_CORE */
+
+#ifndef PTRSIZE
+# define PTRSIZE sizeof(void*)
+#endif
+
#ifndef BITS_IN_PTR
# define BITS_IN_PTR (8*PTRSIZE)
#endif
@@ -908,6 +1015,101 @@ extern Malloc_t sbrk(int);
# endif
#endif
+#ifndef MIN_SBRK_FRAC1000 /* Backward compatibility */
+# define MIN_SBRK_FRAC1000 (MIN_SBRK_FRAC * 10)
+#endif
+
+#ifndef START_EXTERN_C
+# ifdef __cplusplus
+# define START_EXTERN_C extern "C" {
+# else
+# define START_EXTERN_C
+# endif
+#endif
+
+#ifndef END_EXTERN_C
+# ifdef __cplusplus
+# define END_EXTERN_C };
+# else
+# define END_EXTERN_C
+# endif
+#endif
+
+#include "malloc_ctl.h"
+
+#ifndef NO_MALLOC_DYNAMIC_CFG
+# define PERL_MALLOC_OPT_CHARS "FMfAPGdac"
+
+# ifndef FILL_DEAD_DEFAULT
+# define FILL_DEAD_DEFAULT 1
+# endif
+# ifndef FILL_ALIVE_DEFAULT
+# define FILL_ALIVE_DEFAULT 1
+# endif
+# ifndef FILL_CHECK_DEFAULT
+# define FILL_CHECK_DEFAULT 1
+# endif
+
+static IV MallocCfg[MallocCfg_last] = {
+ FIRST_SBRK,
+ MIN_SBRK,
+ MIN_SBRK_FRAC,
+ SBRK_ALLOW_FAILURES,
+ SBRK_FAILURE_PRICE,
+ SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE, /* sbrk_goodness */
+ FILL_DEAD_DEFAULT, /* FILL_DEAD */
+ FILL_ALIVE_DEFAULT, /* FILL_ALIVE */
+ FILL_CHECK_DEFAULT, /* FILL_CHECK */
+ 0, /* MallocCfg_skip_cfg_env */
+ 0, /* MallocCfg_cfg_env_read */
+ 0, /* MallocCfg_emergency_buffer_size */
+ 0, /* MallocCfg_emergency_buffer_prepared_size */
+ 0 /* MallocCfg_emergency_buffer_last_req */
+};
+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
+# undef SBRK_ALLOW_FAILURES
+# undef SBRK_FAILURE_PRICE
+
+# define MIN_SBRK MallocCfg[MallocCfg_MIN_SBRK]
+# define FIRST_SBRK MallocCfg[MallocCfg_FIRST_SBRK]
+# define MIN_SBRK_FRAC1000 MallocCfg[MallocCfg_MIN_SBRK_FRAC1000]
+# define SBRK_ALLOW_FAILURES MallocCfg[MallocCfg_SBRK_ALLOW_FAILURES]
+# define SBRK_FAILURE_PRICE MallocCfg[MallocCfg_SBRK_FAILURE_PRICE]
+
+# define sbrk_goodness MallocCfg[MallocCfg_sbrk_goodness]
+
+# define emergency_buffer_size MallocCfg[MallocCfg_emergency_buffer_size]
+# define emergency_buffer_last_req MallocCfg[MallocCfg_emergency_buffer_last_req]
+
+# define FILL_DEAD MallocCfg[MallocCfg_filldead]
+# define FILL_ALIVE MallocCfg[MallocCfg_fillalive]
+# 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
+# define FILL_ALIVE 1
+# define FILL_CHECK 1
+static int sbrk_goodness = SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE;
+
+# define NO_PERL_MALLOC_ENV
+
+#endif
+
#ifdef DEBUGGING_MSTATS
/*
* nmalloc[i] is the difference between the number of mallocs and frees
@@ -922,27 +1124,106 @@ static u_int start_slack;
static u_int goodsbrk;
-# ifdef PERL_EMERGENCY_SBRK
+#ifdef PERL_EMERGENCY_SBRK
# ifndef BIG_SIZE
# define BIG_SIZE (1<<16) /* 64K */
# endif
-static char *emergency_buffer;
+# ifdef NO_MALLOC_DYNAMIC_CFG
static MEM_SIZE emergency_buffer_size;
-static MEM_SIZE no_mem; /* 0 if the last request for more memory succeeded.
- Otherwise the size of the failing request. */
+ /* 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
+# define emergency_sbrk_croak croak2
+# endif
+
+# ifdef PERL_CORE
+static char *
+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;
+
+ if (!gvp) gvp = (GV**)hv_fetch(PL_defstash, "\015", 1, 0);
+ if (!gvp || !(sv = GvSV(*gvp)) || !SvPOK(sv)
+ || (SvLEN(sv) < (1<<LOG_OF_MIN_ARENA) - M_OVERHEAD))
+ return NULL; /* Now die die die... */
+ /* Got it, now detach SvPV: */
+ pv = SvPV(sv, n_a);
+ /* Check alignment: */
+ if ((PTR2UV(pv) - sizeof(union overhead)) & (NEEDED_ALIGNMENT - 1)) {
+ PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n");
+ return NULL; /* die die die */
+ }
+
+ SvPOK_off(sv);
+ SvPVX(sv) = Nullch;
+ SvCUR(sv) = SvLEN(sv) = 0;
+ *size = malloced_size(pv) + M_OVERHEAD;
+ return pv - sizeof(union overhead);
+}
+# define PERL_GET_EMERGENCY_BUFFER(p) perl_get_emergency_buffer(p)
+# else
+# define PERL_GET_EMERGENCY_BUFFER(p) NULL
+# endif /* defined PERL_CORE */
+
+# ifndef NO_MALLOC_DYNAMIC_CFG
+static char *
+get_emergency_buffer(IV *size)
+{
+ char *pv = emergency_buffer_prepared;
+
+ *size = MallocCfg[MallocCfg_emergency_buffer_prepared_size];
+ emergency_buffer_prepared = 0;
+ MallocCfg[MallocCfg_emergency_buffer_prepared_size] = 0;
+ return pv;
+}
+
+/* Returns 0 on success, -1 on bad alignment, -2 if not implemented */
+int
+set_emergency_buffer(char *b, IV size)
+{
+ if (PTR2UV(b) & (NEEDED_ALIGNMENT - 1))
+ return -1;
+ if (MallocCfg[MallocCfg_emergency_buffer_prepared_size])
+ add_to_chain((void*)emergency_buffer_prepared,
+ MallocCfg[MallocCfg_emergency_buffer_prepared_size], 0);
+ emergency_buffer_prepared = b;
+ MallocCfg[MallocCfg_emergency_buffer_prepared_size] = size;
+ return 0;
+}
+# define GET_EMERGENCY_BUFFER(p) get_emergency_buffer(p)
+# else /* NO_MALLOC_DYNAMIC_CFG */
+# define GET_EMERGENCY_BUFFER(p) NULL
+int
+set_emergency_buffer(char *b, IV size)
+{
+ return -1;
+}
+# endif
static Malloc_t
emergency_sbrk(MEM_SIZE size)
{
MEM_SIZE rsize = (((size - 1)>>LOG_OF_MIN_ARENA) + 1)<<LOG_OF_MIN_ARENA;
- if (size >= BIG_SIZE && (!no_mem || (size < no_mem))) {
+ if (size >= BIG_SIZE
+ && (!emergency_buffer_last_req || (size < emergency_buffer_last_req))) {
/* Give the possibility to recover, but avoid an infinite cycle. */
MALLOC_UNLOCK;
- no_mem = size;
- croak2("Out of memory during \"large\" request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack));
+ 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) {
@@ -952,14 +1233,11 @@ emergency_sbrk(MEM_SIZE size)
emergency_buffer += rsize;
return old;
} else {
- 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;
+ IV Size;
+ char *pv = GET_EMERGENCY_BUFFER(&Size);
int have = 0;
- STRLEN n_a;
if (emergency_buffer_size) {
add_to_chain(emergency_buffer, emergency_buffer_size, 0);
@@ -967,53 +1245,159 @@ emergency_sbrk(MEM_SIZE size)
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<<LOG_OF_MIN_ARENA) - M_OVERHEAD)) {
+
+ if (!pv)
+ pv = PERL_GET_EMERGENCY_BUFFER(&Size);
+ if (!pv) {
if (have)
goto do_croak;
return (char *)-1; /* Now die die die... */
}
- /* Got it, now detach SvPV: */
- pv = SvPV(sv, n_a);
+
/* Check alignment: */
- if ((PTR2UV(pv) - sizeof(union overhead)) & (NEEDED_ALIGNMENT - 1)) {
+ if (PTR2UV(pv) & (NEEDED_ALIGNMENT - 1)) {
+ dTHX;
+
PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n");
return (char *)-1; /* die die die */
}
- emergency_buffer = pv - sizeof(union overhead);
- emergency_buffer_size = malloced_size(pv) + M_OVERHEAD;
- SvPOK_off(sv);
- SvPVX(sv) = Nullch;
- SvCUR(sv) = SvLEN(sv) = 0;
+ emergency_buffer = pv;
+ emergency_buffer_size = Size;
}
do_croak:
MALLOC_UNLOCK;
- croak("Out of memory during request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack));
+ 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;
}
-# else /* !defined(PERL_EMERGENCY_SBRK) */
+#else /* !defined(PERL_EMERGENCY_SBRK) */
# define emergency_sbrk(size) -1
-# endif
-#endif /* ifdef PERL_CORE */
+#endif /* defined PERL_EMERGENCY_SBRK */
+
+static void
+write2(char *mess)
+{
+ write(2, mess, strlen(mess));
+}
#ifdef DEBUGGING
#undef ASSERT
-#define ASSERT(p,diag) if (!(p)) botch(diag,STRINGIFY(p)); else
+#define ASSERT(p,diag) if (!(p)) botch(diag,STRINGIFY(p),__FILE__,__LINE__); else
static void
-botch(char *diag, char *s)
+botch(char *diag, char *s, char *file, int line)
{
+ if (!(PERL_MAYBE_ALIVE && PERL_GET_THX))
+ goto do_write;
+ else {
dTHX;
- PerlIO_printf(PerlIO_stderr(), "assertion botched (%s?): %s\n", diag, s);
+ if (PerlIO_printf(PerlIO_stderr(),
+ "assertion botched (%s?): %s %s:%d\n",
+ diag, s, file, line) != 0) {
+ do_write: /* Can be initializing interpreter */
+ write2("assertion botched (");
+ write2(diag);
+ write2("?): ");
+ write2(s);
+ write2(" (");
+ write2(file);
+ write2(":");
+ {
+ char linebuf[10];
+ char *s = linebuf + sizeof(linebuf) - 1;
+ int n = line;
+ *s = 0;
+ do {
+ *--s = '0' + (n % 10);
+ } while (n /= 10);
+ write2(s);
+ }
+ write2(")\n");
+ }
PerlProc_abort();
+ }
}
#else
#define ASSERT(p, diag)
#endif
+#ifdef MALLOC_FILL
+/* Fill should be long enough to cover long */
+static void
+fill_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill)
+{
+ unsigned char *e = s + nbytes;
+ long *lp;
+ long lfill = *(long*)fill;
+
+ if (PTR2UV(s) & (sizeof(long)-1)) { /* Align the pattern */
+ int shift = sizeof(long) - (PTR2UV(s) & (sizeof(long)-1));
+ unsigned const char *f = fill + sizeof(long) - shift;
+ unsigned char *e1 = s + shift;
+
+ while (s < e1)
+ *s++ = *f++;
+ }
+ lp = (long*)s;
+ while ((unsigned char*)(lp + 1) <= e)
+ *lp++ = lfill;
+ s = (unsigned char*)lp;
+ while (s < e)
+ *s++ = *fill++;
+}
+/* Just malloc()ed */
+static const unsigned char fill_feedadad[] =
+ {0xFE, 0xED, 0xAD, 0xAD, 0xFE, 0xED, 0xAD, 0xAD,
+ 0xFE, 0xED, 0xAD, 0xAD, 0xFE, 0xED, 0xAD, 0xAD};
+/* Just free()ed */
+static const unsigned char fill_deadbeef[] =
+ {0xDE, 0xAD, 0xBE, 0xEF, 0xDE, 0xAD, 0xBE, 0xEF,
+ 0xDE, 0xAD, 0xBE, 0xEF, 0xDE, 0xAD, 0xBE, 0xEF};
+# define FILL_DEADBEEF(s, n) \
+ (void)(FILL_DEAD? (fill_pat_4bytes((s), (n), fill_deadbeef), 0) : 0)
+# define FILL_FEEDADAD(s, n) \
+ (void)(FILL_ALIVE? (fill_pat_4bytes((s), (n), fill_feedadad), 0) : 0)
+#else
+# define FILL_DEADBEEF(s, n) ((void)0)
+# define FILL_FEEDADAD(s, n) ((void)0)
+# undef MALLOC_FILL_CHECK
+#endif
+
+#ifdef MALLOC_FILL_CHECK
+static int
+cmp_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill)
+{
+ unsigned char *e = s + nbytes;
+ long *lp;
+ long lfill = *(long*)fill;
+
+ if (PTR2UV(s) & (sizeof(long)-1)) { /* Align the pattern */
+ int shift = sizeof(long) - (PTR2UV(s) & (sizeof(long)-1));
+ unsigned const char *f = fill + sizeof(long) - shift;
+ unsigned char *e1 = s + shift;
+
+ while (s < e1)
+ if (*s++ != *f++)
+ return 1;
+ }
+ lp = (long*)s;
+ while ((unsigned char*)(lp + 1) <= e)
+ if (*lp++ != lfill)
+ return 1;
+ s = (unsigned char*)lp;
+ while (s < e)
+ if (*s++ != *fill++)
+ return 1;
+ return 0;
+}
+# define FILLCHECK_DEADBEEF(s, n) \
+ ASSERT(!FILL_CHECK || !cmp_pat_4bytes(s, n, fill_deadbeef), \
+ "free()ed/realloc()ed-away memory was overwritten")
+#else
+# define FILLCHECK_DEADBEEF(s, n) ((void)0)
+#endif
+
Malloc_t
Perl_malloc(register size_t nbytes)
{
@@ -1111,14 +1495,17 @@ Perl_malloc(register size_t nbytes)
}
/* remove from linked list */
-#if defined(RCHECK)
- if ((PTR2UV(p)) & (MEM_ALIGNBYTES - 1)) {
+#ifdef DEBUGGING
+ if ( (PTR2UV(p) & (MEM_ALIGNBYTES - 1))
+ /* Can't get this low */
+ || (p && PTR2UV(p) < (1<<LOG_OF_MIN_ARENA)) ) {
dTHX;
PerlIO_printf(PerlIO_stderr(),
"Unaligned pointer in the free chain 0x%"UVxf"\n",
PTR2UV(p));
}
- if ((PTR2UV(p->ov_next)) & (MEM_ALIGNBYTES - 1)) {
+ if ( (PTR2UV(p->ov_next) & (MEM_ALIGNBYTES - 1))
+ || (p->ov_next && PTR2UV(p->ov_next) < (1<<LOG_OF_MIN_ARENA)) ) {
dTHX;
PerlIO_printf(PerlIO_stderr(),
"Unaligned `next' pointer in the free "
@@ -1132,9 +1519,12 @@ Perl_malloc(register size_t nbytes)
DEBUG_m(PerlIO_printf(Perl_debug_log,
"0x%"UVxf": (%05lu) malloc %ld bytes\n",
- PTR2UV(p), (unsigned long)(PL_an++),
+ PTR2UV((Malloc_t)(p + CHUNK_SHIFT)), (unsigned long)(PL_an++),
(long)size));
+ FILLCHECK_DEADBEEF((unsigned char*)(p + CHUNK_SHIFT),
+ BUCKET_SIZE_REAL(bucket) + RMAGIC_SZ);
+
#ifdef IGNORE_SMALL_BAD_FREE
if (bucket >= FIRST_BUCKET_WITH_CHECK)
#endif
@@ -1153,14 +1543,16 @@ Perl_malloc(register size_t nbytes)
nbytes = size + M_OVERHEAD;
p->ov_size = nbytes - 1;
- if ((i = nbytes & 3)) {
- i = 4 - i;
- while (i--)
- *((char *)((caddr_t)p + nbytes - RSLOP + i)) = RMAGIC_C;
+ if ((i = nbytes & (RMAGIC_SZ-1))) {
+ i = RMAGIC_SZ - i;
+ while (i--) /* nbytes - RMAGIC_SZ is end of alloced area */
+ ((caddr_t)p + nbytes - RMAGIC_SZ)[i] = RMAGIC_C;
}
- nbytes = (nbytes + 3) &~ 3;
- *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
+ /* Same at RMAGIC_SZ-aligned RMAGIC */
+ nbytes = (nbytes + RMAGIC_SZ - 1) & ~(RMAGIC_SZ - 1);
+ ((u_int *)((caddr_t)p + nbytes))[-1] = RMAGIC;
}
+ FILL_FEEDADAD((unsigned char *)(p + CHUNK_SHIFT), size);
#endif
return ((Malloc_t)(p + CHUNK_SHIFT));
}
@@ -1168,7 +1560,6 @@ Perl_malloc(register size_t nbytes)
static char *last_sbrk_top;
static char *last_op; /* This arena can be easily extended. */
static MEM_SIZE sbrked_remains;
-static int sbrk_good = SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE;
#ifdef DEBUGGING_MSTATS
static int sbrks;
@@ -1254,7 +1645,7 @@ get_from_bigger_buckets(int bucket, MEM_SIZE size)
nmalloc[bucket]--;
start_slack -= M_OVERHEAD;
#endif
- add_to_chain(ret, (BUCKET_SIZE(bucket) +
+ add_to_chain(ret, (BUCKET_SIZE_NO_SURPLUS(bucket) +
POW2_OPTIMIZE_SURPLUS(bucket)),
size);
return ret;
@@ -1274,13 +1665,13 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket)
union overhead *ovp;
MEM_SIZE slack = 0;
- if (sbrk_good > 0) {
+ if (sbrk_goodness > 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;
+ if (require < goodsbrk * MIN_SBRK_FRAC1000 / 1000)
+ require = goodsbrk * MIN_SBRK_FRAC1000 / 1000;
require = ((require - 1 + MIN_SBRK) / MIN_SBRK) * MIN_SBRK;
} else {
require = needed;
@@ -1297,7 +1688,7 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket)
#endif
if (cp == last_sbrk_top) {
/* Common case, anything is fine. */
- sbrk_good++;
+ sbrk_goodness++;
ovp = (union overhead *) (cp - sbrked_remains);
last_op = cp - sbrked_remains;
sbrked_remains = require - (needed - sbrked_remains);
@@ -1369,7 +1760,7 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket)
if (cp == (char *)-1)
return 0;
}
- sbrk_good = -1; /* Disable optimization!
+ sbrk_goodness = -1; /* Disable optimization!
Continue with not-aligned... */
} else {
cp += slack;
@@ -1378,7 +1769,7 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket)
}
if (last_sbrk_top) {
- sbrk_good -= SBRK_FAILURE_PRICE;
+ sbrk_goodness -= SBRK_FAILURE_PRICE;
}
ovp = (union overhead *) cp;
@@ -1411,7 +1802,7 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket)
last_op = cp;
}
#if !defined(PLAIN_MALLOC) && !defined(NO_FANCY_MALLOC)
- no_mem = 0;
+ emergency_buffer_last_req = 0;
#endif
last_sbrk_top = cp + require;
#ifdef DEBUGGING_MSTATS
@@ -1450,7 +1841,7 @@ getpages_adjacent(MEM_SIZE require)
add_to_chain((void*)(last_sbrk_top - sbrked_remains),
sbrked_remains, 0);
add_to_chain((void*)cp, require, 0);
- sbrk_good -= SBRK_FAILURE_PRICE;
+ sbrk_goodness -= SBRK_FAILURE_PRICE;
sbrked_remains = 0;
last_sbrk_top = 0;
last_op = 0;
@@ -1471,9 +1862,44 @@ morecore(register int bucket)
register int rnu; /* 2^rnu bytes will be requested */
int nblks; /* become nblks blocks of the desired size */
register MEM_SIZE siz, needed;
+ static int were_called = 0;
if (nextf[bucket])
return;
+#ifndef NO_PERL_MALLOC_ENV
+ if (!were_called) {
+ /* It's the 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, *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 (*t <= '9' && *t >= '0')
+ 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) {
+ write2("Unrecognized part of PERL_MALLOC_OPT: `");
+ write2(t);
+ write2("'\n");
+ }
+ if (changed)
+ MallocCfg[MallocCfg_cfg_env_read] = 1;
+ }
+ }
+#endif
if (bucket == sizeof(MEM_SIZE)*8*BUCKETS_PER_POW2) {
MALLOC_UNLOCK;
croak("%s", "Out of memory during ridiculously large request");
@@ -1518,12 +1944,13 @@ morecore(register int bucket)
if (!ovp)
return;
+ FILL_DEADBEEF((unsigned char*)ovp, needed);
/*
* Add new memory allocated to that on
* free list for this hash bucket.
*/
- siz = BUCKET_SIZE(bucket);
+ siz = BUCKET_SIZE_NO_SURPLUS(bucket); /* No surplus if nblks > 1 */
#ifdef PACK_MALLOC
*(u_char*)ovp = bucket; /* Fill index. */
if (bucket <= MAX_PACKED) {
@@ -1544,6 +1971,7 @@ morecore(register int bucket)
start_slack += M_OVERHEAD * nblks;
}
#endif
+
while (--nblks > 0) {
ovp->ov_next = (union overhead *)((caddr_t)ovp + siz);
ovp = (union overhead *)((caddr_t)ovp + siz);
@@ -1577,6 +2005,10 @@ Perl_mfree(void *mp)
if (cp == NULL)
return;
+#ifdef DEBUGGING
+ if (PTR2UV(cp) & (MEM_ALIGNBYTES - 1))
+ croak("%s", "wrong alignment in free()");
+#endif
ovp = (union overhead *)((caddr_t)cp
- sizeof (union overhead) * CHUNK_SHIFT);
#ifdef PACK_MALLOC
@@ -1629,16 +2061,22 @@ Perl_mfree(void *mp)
int i;
MEM_SIZE nbytes = ovp->ov_size + 1;
- if ((i = nbytes & 3)) {
- i = 4 - i;
- while (i--) {
- ASSERT(*((char *)((caddr_t)ovp + nbytes - RSLOP + i))
- == RMAGIC_C, "chunk's tail overwrite");
+ if ((i = nbytes & (RMAGIC_SZ-1))) {
+ i = RMAGIC_SZ - i;
+ while (i--) { /* nbytes - RMAGIC_SZ is end of alloced area */
+ ASSERT(((caddr_t)ovp + nbytes - RMAGIC_SZ)[i] == RMAGIC_C,
+ "chunk's tail overwrite");
}
}
- nbytes = (nbytes + 3) &~ 3;
- ASSERT(*(u_int *)((caddr_t)ovp + nbytes - RSLOP) == RMAGIC, "chunk's tail overwrite");
+ /* Same at RMAGIC_SZ-aligned RMAGIC */
+ nbytes = (nbytes + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ-1);
+ ASSERT(((u_int *)((caddr_t)ovp + nbytes))[-1] == RMAGIC,
+ "chunk's tail overwrite");
+ FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nbytes),
+ BUCKET_SIZE(OV_INDEX(ovp)) - nbytes);
}
+ FILL_DEADBEEF((unsigned char*)(ovp+CHUNK_SHIFT),
+ BUCKET_SIZE_REAL(OV_INDEX(ovp)) + RMAGIC_SZ);
ovp->ov_rmagic = RMAGIC - 1;
#endif
ASSERT(OV_INDEX(ovp) < NBUCKETS, "chunk's head overwrite");
@@ -1708,9 +2146,9 @@ Perl_realloc(void *mp, size_t nbytes)
? "of freed memory " : "");
}
#else
- warn("%srealloc() %signored",
- (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "),
- ovp->ov_rmagic == RMAGIC - 1 ? "of freed memory " : "");
+ warn2("%srealloc() %signored",
+ (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "),
+ ovp->ov_rmagic == RMAGIC - 1 ? "of freed memory " : "");
#endif
#else
#ifdef PERL_CORE
@@ -1768,14 +2206,24 @@ Perl_realloc(void *mp, size_t nbytes)
if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) {
int i, nb = ovp->ov_size + 1;
- if ((i = nb & 3)) {
- i = 4 - i;
- while (i--) {
- ASSERT(*((char *)((caddr_t)ovp + nb - RSLOP + i)) == RMAGIC_C, "chunk's tail overwrite");
+ if ((i = nb & (RMAGIC_SZ-1))) {
+ i = RMAGIC_SZ - i;
+ while (i--) { /* nb - RMAGIC_SZ is end of alloced area */
+ ASSERT(((caddr_t)ovp + nb - RMAGIC_SZ)[i] == RMAGIC_C, "chunk's tail overwrite");
}
}
- nb = (nb + 3) &~ 3;
- ASSERT(*(u_int *)((caddr_t)ovp + nb - RSLOP) == RMAGIC, "chunk's tail overwrite");
+ /* Same at RMAGIC_SZ-aligned RMAGIC */
+ nb = (nb + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ-1);
+ ASSERT(((u_int *)((caddr_t)ovp + nb))[-1] == RMAGIC,
+ "chunk's tail overwrite");
+ FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nb),
+ BUCKET_SIZE(OV_INDEX(ovp)) - nb);
+ if (nbytes > ovp->ov_size + 1 - M_OVERHEAD)
+ FILL_FEEDADAD((unsigned char*)cp + ovp->ov_size + 1 - M_OVERHEAD,
+ nbytes - (ovp->ov_size + 1 - M_OVERHEAD));
+ else
+ FILL_DEADBEEF((unsigned char*)cp + nbytes,
+ nb - M_OVERHEAD + RMAGIC_SZ - nbytes);
/*
* Convert amount of memory requested into
* closest block size stored in hash buckets
@@ -1784,14 +2232,15 @@ Perl_realloc(void *mp, size_t nbytes)
*/
nbytes += M_OVERHEAD;
ovp->ov_size = nbytes - 1;
- if ((i = nbytes & 3)) {
- i = 4 - i;
- while (i--)
- *((char *)((caddr_t)ovp + nbytes - RSLOP + i))
+ if ((i = nbytes & (RMAGIC_SZ-1))) {
+ i = RMAGIC_SZ - i;
+ while (i--) /* nbytes - RMAGIC_SZ is end of alloced area */
+ ((caddr_t)ovp + nbytes - RMAGIC_SZ)[i]
= RMAGIC_C;
}
- nbytes = (nbytes + 3) &~ 3;
- *((u_int *)((caddr_t)ovp + nbytes - RSLOP)) = RMAGIC;
+ /* Same at RMAGIC_SZ-aligned RMAGIC */
+ nbytes = (nbytes + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ - 1);
+ ((u_int *)((caddr_t)ovp + nbytes))[-1] = RMAGIC;
}
#endif
res = cp;
@@ -1908,7 +2357,7 @@ Perl_malloced_size(void *p)
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;
+ *((u_int *)((caddr_t)ovp + size + M_OVERHEAD - RMAGIC_SZ)) = RMAGIC;
}
#endif
return BUCKET_SIZE_REAL(bucket);
@@ -1954,7 +2403,7 @@ Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level)
}
buf->total_sbrk = goodsbrk + sbrk_slack;
buf->sbrks = sbrks;
- buf->sbrk_good = sbrk_good;
+ buf->sbrk_good = sbrk_goodness;
buf->sbrk_slack = sbrk_slack;
buf->start_slack = start_slack;
buf->sbrked_remains = sbrked_remains;
@@ -1964,7 +2413,7 @@ Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level)
for (i = MIN_BUCKET ; i < NBUCKETS; i++) {
if (i >= buflen)
break;
- buf->bucket_mem_size[i] = BUCKET_SIZE(i);
+ buf->bucket_mem_size[i] = BUCKET_SIZE_NO_SURPLUS(i);
buf->bucket_available_size[i] = BUCKET_SIZE_REAL(i);
}
}
@@ -1996,9 +2445,9 @@ Perl_dump_mstats(pTHX_ char *s)
"Memory allocation statistics %s (buckets %"IVdf"(%"IVdf")..%"IVdf"(%"IVdf")\n",
s,
(IV)BUCKET_SIZE_REAL(MIN_BUCKET),
- (IV)BUCKET_SIZE(MIN_BUCKET),
+ (IV)BUCKET_SIZE_NO_SURPLUS(MIN_BUCKET),
(IV)BUCKET_SIZE_REAL(buffer.topbucket),
- (IV)BUCKET_SIZE(buffer.topbucket));
+ (IV)BUCKET_SIZE_NO_SURPLUS(buffer.topbucket));
PerlIO_printf(Perl_error_log, "%8"IVdf" free:", buffer.totfree);
for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) {
PerlIO_printf(Perl_error_log,