*/
/*
- * "'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.
+ * 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.)
-
+ 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
# Enable code for an emergency memory pool in $^M. See perlvar.pod
# for a description of $^M.
- PERL_EMERGENCY_SBRK (!PLAIN_MALLOC && (PERL_CORE || !NO_MALLOC_DYNAMIC_CFG))
+ PERL_EMERGENCY_SBRK !PLAIN_MALLOC
# Enable code for printing memory statistics.
- DEBUGGING_MSTATS (!PLAIN_MALLOC && PERL_CORE)
+ DEBUGGING_MSTATS !PLAIN_MALLOC
# Move allocation info for small buckets into separate areas.
# Memory optimization (especially for small allocations, of the
*/
-/*
- If used outside of Perl environment, it may be useful to redefine
- the following macros (listed below with defaults):
-
- # Type of address returned by allocation functions
- Malloc_t void *
-
- # Type of size argument for allocation functions
- MEM_SIZE unsigned long
-
- # size of void*
- PTRSIZE 4
-
- # Maximal value in LONG
- LONG_MAX 0x7FFFFFFF
-
- # 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)
-
- # Fatal error reporting function
- croak(format, arg) warn(idem) + exit(1)
-
- # Fatal error reporting function
- croak2(format, arg1, arg2) warn2(idem) + exit(1)
-
- # Error reporting function
- warn(format, arg) fprintf(stderr, idem)
-
- # Error reporting function
- warn2(format, arg1, arg2) fprintf(stderr, idem)
-
- # Locking/unlocking for MT operation
- MALLOC_LOCK MUTEX_LOCK(&PL_malloc_mutex)
- MALLOC_UNLOCK MUTEX_UNLOCK(&PL_malloc_mutex)
-
- # Locking/unlocking mutex for MT operation
- MUTEX_LOCK(l) void
- MUTEX_UNLOCK(l) void
- */
#ifdef HAVE_MALLOC_CFG_H
# include "malloc_cfg.h"
# ifndef TWO_POT_OPTIMIZE
# define TWO_POT_OPTIMIZE
# endif
-# if (defined(PERL_CORE) || !defined(NO_MALLOC_DYNAMIC_CFG)) && !defined(PERL_EMERGENCY_SBRK)
+# ifndef PERL_EMERGENCY_SBRK
# define PERL_EMERGENCY_SBRK
# endif
-# if defined(PERL_CORE) && !defined(DEBUGGING_MSTATS)
+# ifndef DEBUGGING_MSTATS
# define DEBUGGING_MSTATS
# endif
#endif
#define MIN_BUC_POW2 (sizeof(void*) > 4 ? 3 : 2) /* Allow for 4-byte arena. */
#define MIN_BUCKET (MIN_BUC_POW2 * BUCKETS_PER_POW2)
-#if !(defined(I286) || defined(atarist) || defined(__MINT__))
- /* take 2k unless the block is bigger than that */
-# define LOG_OF_MIN_ARENA 11
-#else
- /* take 16k unless the block is bigger than that
- (80286s like large segments!), probably good on the atari too */
-# define LOG_OF_MIN_ARENA 14
-#endif
+#define LOG_OF_MIN_ARENA 11
-#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.
* than it was, and takes 67% of old heap size for typical usage.)
*
* Allocations of small blocks are now table-driven to many different
- * buckets. Sizes of really big buckets are increased to accomodata
+ * buckets. Sizes of really big buckets are increased to accommodate
* common size=power-of-2 blocks. Running-out-of-memory is made into
* an exception. Deeply configurable and thread-safe.
*
*/
-#ifdef PERL_CORE
-# include "EXTERN.h"
-# define PERL_IN_MALLOC_C
-# include "perl.h"
-# if defined(PERL_IMPLICIT_CONTEXT)
+#include "EXTERN.h"
+#define PERL_IN_MALLOC_C
+#include "perl.h"
+#if defined(PERL_IMPLICIT_CONTEXT)
# define croak Perl_croak_nocontext
# define croak2 Perl_croak_nocontext
# define warn Perl_warn_nocontext
# define warn2 Perl_warn_nocontext
-# else
+#else
# define croak2 croak
# define warn2 warn
-# endif
-# if defined(USE_5005THREADS) || defined(USE_ITHREADS)
+#endif
+#ifdef USE_ITHREADS
# define PERL_MAYBE_ALIVE PL_thr_key
-# else
-# define PERL_MAYBE_ALIVE 1
-# endif
#else
-# ifdef PERL_FOR_X2P
-# include "../EXTERN.h"
-# include "../perl.h"
-# else
-# 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
-# ifndef PTRSIZE
-# define PTRSIZE 4
-# endif
-# ifndef MEM_SIZE
-# define MEM_SIZE unsigned long
-# endif
-# ifndef LONG_MAX
-# define LONG_MAX 0x7FFFFFFF
-# endif
-# ifndef UV
-# define UV unsigned long
-# endif
-# ifndef IV
-# define IV long
-# endif
-# ifndef caddr_t
-# define caddr_t char *
-# endif
-# ifndef Free_t
-# define Free_t void
-# endif
-# define Copy(s,d,n,t) (void)memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
-# 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))
-# endif
-# ifndef croak2 /* make depend */
-# define croak2(mess, arg1, arg2) (warn2((mess), (arg1), (arg2)), exit(1))
-# endif
-# ifndef warn
-# define warn(mess, arg) fprintf(stderr, (mess), (arg))
-# endif
-# ifndef warn2
-# define warn2(mess, arg1, arg2) fprintf(stderr, (mess), (arg1), (arg2))
-# endif
-# ifdef DEBUG_m
-# undef DEBUG_m
-# endif
-# define DEBUG_m(a)
-# ifdef DEBUGGING
-# undef DEBUGGING
-# endif
-# ifndef pTHX
-# define pTHX void
-# define pTHX_
-# ifdef HASATTRIBUTE
-# define dTHX extern int Perl___notused PERL_UNUSED_DECL
-# else
-# define dTHX extern int Perl___notused
-# endif
-# define WITH_THX(s) s
-# endif
-# ifndef PERL_GET_INTERP
-# define PERL_GET_INTERP PL_curinterp
-# endif
-# define PERL_MAYBE_ALIVE 1
-# ifndef Perl_malloc
-# define Perl_malloc malloc
-# endif
-# ifndef Perl_mfree
-# define Perl_mfree free
-# endif
-# ifndef Perl_realloc
-# define Perl_realloc realloc
-# endif
-# ifndef Perl_calloc
-# define Perl_calloc calloc
-# endif
-# ifndef Perl_strdup
-# define Perl_strdup strdup
-# endif
-#endif /* defined PERL_CORE */
+# define PERL_MAYBE_ALIVE 1
+#endif
#ifndef MUTEX_LOCK
# define MUTEX_LOCK(l)
*/
#define u_short unsigned short
-/* 286 and atarist like big chunks, which gives too much overhead. */
-#if (defined(RCHECK) || defined(I286) || defined(atarist) || defined(__MINT__)) && defined(PACK_MALLOC)
+#if defined(RCHECK) && defined(PACK_MALLOC)
# undef PACK_MALLOC
#endif
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 {
/*
u_char ovu_index; /* bucket # */
u_char ovu_magic; /* magic number */
#ifdef RCHECK
+ /* 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
#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) /* 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)
char c;
void *p;
};
-# define ALIGN_SMALL ((int)((caddr_t)&(((struct aligner*)0)->p)))
+# define ALIGN_SMALL ((IV)((caddr_t)&(((struct aligner*)0)->p)))
#else
# define ALIGN_SMALL MEM_ALIGNBYTES
#endif
#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,
};
-# 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
* encodes the size of the chunk, while MAGICn encodes state (used,
* free or non-managed-by-us-so-it-indicates-a-bug) of CHUNKn. MAGIC
* is used for sanity checking purposes only. SOMETHING is 0 or 4K
- * (to make size of big CHUNK accomodate allocations for powers of two
+ * (to make size of big CHUNK accommodate allocations for powers of two
* better).
*
* [There is no need to alignment between chunks, since C rules ensure
#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]
#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,
#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]
#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,
#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) \
# 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. */
# define POW2_OPTIMIZE_SURPLUS(bucket) 0
#endif /* !TWO_POT_OPTIMIZE */
-#if defined(HAS_64K_LIMIT) && defined(PERL_CORE)
-# define BARK_64K_LIMIT(what,nbytes,size) \
- if (nbytes > 0xffff) { \
- PerlIO_printf(PerlIO_stderr(), \
- "%s too large: %lx\n", what, size); \
- my_exit(1); \
- }
-#else /* !HAS_64K_LIMIT || !PERL_CORE */
-# define BARK_64K_LIMIT(what,nbytes,size)
-#endif /* !HAS_64K_LIMIT || !PERL_CORE */
+#define BARK_64K_LIMIT(what,nbytes,size)
#ifndef MIN_SBRK
# define MIN_SBRK 2048
# define SBRK_FAILURE_PRICE 50
#endif
-static void morecore (register int bucket);
+static void morecore (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);
static union overhead *getpages (MEM_SIZE needed, int *nblksp, int bucket);
static int getpages_adjacent(MEM_SIZE require);
-#ifdef PERL_CORE
-
#ifdef I_MACH_CTHREADS
# undef MUTEX_LOCK
# define MUTEX_LOCK(m) STMT_START { if (*m) mutex_lock(*m); } STMT_END
# 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 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,
SBRK_ALLOW_FAILURES,
SBRK_FAILURE_PRICE,
SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE, /* sbrk_goodness */
- 1, /* FILL_DEAD */
- 1, /* FILL_ALIVE */
- 1, /* FILL_CHECK */
+ 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 */
};
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
# 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 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
# 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;
+ 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) - M_OVERHEAD))
return NULL; /* Now die die die... */
/* Got it, now detach SvPV: */
- pv = SvPV(sv, n_a);
+ pv = SvPV_nolen(sv);
/* Check alignment: */
if ((PTR2UV(pv) - sizeof(union overhead)) & (NEEDED_ALIGNMENT - 1)) {
PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n");
}
SvPOK_off(sv);
- SvPVX(sv) = Nullch;
- SvCUR(sv) = SvLEN(sv) = 0;
+ SvPV_set(sv, NULL);
+ SvCUR_set(sv, 0);
+ SvLEN_set(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 */
+# define PERL_GET_EMERGENCY_BUFFER(p) perl_get_emergency_buffer(p)
# ifndef NO_MALLOC_DYNAMIC_CFG
static char *
MEM_SIZE rsize = (((size - 1)>>LOG_OF_MIN_ARENA) + 1)<<LOG_OF_MIN_ARENA;
if (size >= 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;
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;
}
do_croak:
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;
+ assert(0); /* NOTREACHED */
+ return NULL;
}
#else /* !defined(PERL_EMERGENCY_SBRK) */
# define emergency_sbrk(size) -1
#endif /* defined PERL_EMERGENCY_SBRK */
-static void
-write2(char *mess)
-{
- write(2, mess, strlen(mess));
-}
+/* Don't use PerlIO buffered writes as they allocate memory. */
+#define MYMALLOC_WRITE2STDERR(s) PerlLIO_write(PerlIO_fileno(PerlIO_stderr()),s,strlen(s))
#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 %s:%d\n",
+ "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(":");
+ MYMALLOC_WRITE2STDERR("assertion botched (");
+ MYMALLOC_WRITE2STDERR(diag);
+ MYMALLOC_WRITE2STDERR("?): ");
+ MYMALLOC_WRITE2STDERR(s);
+ MYMALLOC_WRITE2STDERR(" (");
+ MYMALLOC_WRITE2STDERR(file);
+ MYMALLOC_WRITE2STDERR(":");
{
char linebuf[10];
char *s = linebuf + sizeof(linebuf) - 1;
do {
*--s = '0' + (n % 10);
} while (n /= 10);
- write2(s);
+ MYMALLOC_WRITE2STDERR(s);
}
- write2(")\n");
+ MYMALLOC_WRITE2STDERR(")\n");
}
PerlProc_abort();
}
{
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));
{
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));
# define FILLCHECK_DEADBEEF(s, n) ((void)0)
#endif
-Malloc_t
-Perl_malloc(register size_t nbytes)
+STATIC int
+S_adjust_size_and_find_bucket(size_t *nbytes_p)
{
- register union overhead *p;
- register int bucket;
- register MEM_SIZE shiftr;
+ MEM_SIZE shiftr;
+ int bucket;
+ size_t nbytes;
-#if defined(DEBUGGING) || defined(RCHECK)
- MEM_SIZE size = nbytes;
-#endif
+ PERL_ARGS_ASSERT_ADJUST_SIZE_AND_FIND_BUCKET;
- BARK_64K_LIMIT("Allocation",nbytes,nbytes);
-#ifdef DEBUGGING
- if ((long)nbytes < 0)
- croak("%s", "panic: malloc");
-#endif
+ nbytes = *nbytes_p;
/*
* Convert amount of memory requested into
while (shiftr >>= 1)
bucket += BUCKETS_PER_POW2;
}
+ *nbytes_p = nbytes;
+ return bucket;
+}
+
+Malloc_t
+Perl_malloc(size_t nbytes)
+{
+ dVAR;
+ union overhead *p;
+ 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 = adjust_size_and_find_bucket(&nbytes);
MALLOC_LOCK;
/*
* If nothing in hash bucket right now,
morecore(bucket);
if ((p = nextf[bucket]) == NULL) {
MALLOC_UNLOCK;
-#ifdef PERL_CORE
{
dTHX;
if (!PL_nomemok) {
#if defined(PLAIN_MALLOC) && defined(NO_FANCY_MALLOC)
- PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
+ MYMALLOC_WRITE2STDERR("Out of memory!\n");
#else
char buff[80];
char *eb = buff + sizeof(buff) - 1;
char *s = eb;
size_t n = nbytes;
- PerlIO_puts(PerlIO_stderr(),"Out of memory during request for ");
+ MYMALLOC_WRITE2STDERR("Out of memory during request for ");
#if defined(DEBUGGING) || defined(RCHECK)
n = size;
#endif
do {
*--s = '0' + (n % 10);
} while (n /= 10);
- PerlIO_puts(PerlIO_stderr(),s);
- PerlIO_puts(PerlIO_stderr()," bytes, total sbrk() is ");
+ MYMALLOC_WRITE2STDERR(s);
+ MYMALLOC_WRITE2STDERR(" bytes, total sbrk() is ");
s = eb;
n = goodsbrk + sbrk_slack;
do {
*--s = '0' + (n % 10);
} while (n /= 10);
- PerlIO_puts(PerlIO_stderr(),s);
- PerlIO_puts(PerlIO_stderr()," bytes!\n");
+ MYMALLOC_WRITE2STDERR(s);
+ MYMALLOC_WRITE2STDERR(" bytes!\n");
#endif /* defined(PLAIN_MALLOC) && defined(NO_FANCY_MALLOC) */
my_exit(1);
}
}
-#endif
return (NULL);
}
|| (p->ov_next && PTR2UV(p->ov_next) < (1<<LOG_OF_MIN_ARENA)) ) {
dTHX;
PerlIO_printf(PerlIO_stderr(),
- "Unaligned `next' pointer in the free "
+ "Unaligned \"next\" pointer in the free "
"chain 0x%"UVxf" at 0x%"UVxf"\n",
PTR2UV(p->ov_next), PTR2UV(p));
}
(long)size));
FILLCHECK_DEADBEEF((unsigned char*)(p + CHUNK_SHIFT),
- BUCKET_SIZE_REAL(bucket));
+ BUCKET_SIZE_REAL(bucket) + RMAGIC_SZ);
#ifdef IGNORE_SMALL_BAD_FREE
if (bucket >= FIRST_BUCKET_WITH_CHECK)
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
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;
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;
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)
+ 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 {
/* Second, check alignment. */
slack = 0;
-#if !defined(atarist) && !defined(__MINT__) /* on the atari we dont have to worry about this */
-# ifndef I286 /* The sbrk(0) call on the I286 always returns the next segment */
/* 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;
}
-# endif
-#endif /* !atarist && !MINT */
if (add) {
DEBUG_m(PerlIO_printf(Perl_debug_log,
fatalcroak("Misalignment of sbrk()\n");
else
# endif
-#ifndef I286 /* Again, this should always be ok on an 80286 */
if (PTR2UV(ovp) & (MEM_ALIGNBYTES - 1)) {
DEBUG_m(PerlIO_printf(Perl_debug_log,
- "fixing sbrk(): %d bytes off machine alignement\n",
+ "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));
sbrk_slack += (1 << (bucket >> BUCKET_POW2_SHIFT));
# endif
}
-#endif
- ; /* Finish `else' */
+ ; /* Finish "else" */
sbrked_remains = require - needed;
last_op = cp;
}
* Allocate more memory to the indicated bucket.
*/
static void
-morecore(register int bucket)
+morecore(int bucket)
{
- register union overhead *ovp;
- register int rnu; /* 2^rnu bytes will be requested */
+ dVAR;
+ union overhead *ovp;
+ int rnu; /* 2^rnu bytes will be requested */
int nblks; /* become nblks blocks of the desired size */
- register MEM_SIZE siz, needed;
+ MEM_SIZE siz, needed;
static int were_called = 0;
if (nextf[bucket])
}
}
if (t && *t) {
- write2("Unrecognized part of PERL_MALLOC_OPT: `");
- write2(t);
- write2("'\n");
+ dTHX;
+ MYMALLOC_WRITE2STDERR("Unrecognized part of PERL_MALLOC_OPT: \"");
+ MYMALLOC_WRITE2STDERR(t);
+ MYMALLOC_WRITE2STDERR("\"\n");
}
if (changed)
MallocCfg[MallocCfg_cfg_env_read] = 1;
* 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) {
}
Free_t
-Perl_mfree(void *mp)
+Perl_mfree(Malloc_t where)
{
- register MEM_SIZE size;
- register union overhead *ovp;
- char *cp = (char*)mp;
+ dVAR;
+ MEM_SIZE size;
+ union overhead *ovp;
+ char *cp = (char*)where;
#ifdef PACK_MALLOC
u_char bucket;
#endif
if (!bad_free_warn)
return;
#ifdef RCHECK
-#ifdef PERL_CORE
{
dTHX;
- if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
- Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s free() ignored (RMAGIC, PERL_CORE)",
- ovp->ov_rmagic == RMAGIC - 1 ?
- "Duplicate" : "Bad");
+ if (!PERL_IS_ALIVE || !PL_curcop)
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s free() ignored (RMAGIC, PERL_CORE)",
+ ovp->ov_rmagic == RMAGIC - 1 ?
+ "Duplicate" : "Bad");
}
#else
- warn("%s free() ignored (RMAGIC)",
- ovp->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
-#endif
-#else
-#ifdef PERL_CORE
{
dTHX;
- if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
- Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s", "Bad free() ignored (PERL_CORE)");
+ if (!PERL_IS_ALIVE || !PL_curcop)
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s", "Bad free() ignored (PERL_CORE)");
}
-#else
- warn("%s", "Bad free() ignored");
-#endif
#endif
return; /* sanity */
}
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");
- FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nbytes - RSLOP + sizeof(u_int)),
- BUCKET_SIZE_REAL(OV_INDEX(ovp)) - (nbytes - RSLOP + sizeof(u_int)));
+ /* 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+1), BUCKET_SIZE_REAL(OV_INDEX(ovp)));
+ 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");
Malloc_t
Perl_realloc(void *mp, size_t nbytes)
{
- register MEM_SIZE onb;
+ dVAR;
+ MEM_SIZE onb;
union overhead *ovp;
char *res;
int prev_bucket;
- register int bucket;
+ int bucket;
int incr; /* 1 if does not fit, -1 if "easily" fits in a
smaller bucket, otherwise 0. */
char *cp = (char*)mp;
-#if defined(DEBUGGING) || !defined(PERL_CORE)
+#ifdef DEBUGGING
MEM_SIZE size = nbytes;
if ((long)nbytes < 0)
bad_free_warn = (pbf) ? atoi(pbf) : 1;
}
if (!bad_free_warn)
- return Nullch;
+ return NULL;
#ifdef RCHECK
-#ifdef PERL_CORE
{
dTHX;
- if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
- Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%srealloc() %signored",
- (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "),
- ovp->ov_rmagic == RMAGIC - 1
- ? "of freed memory " : "");
+ if (!PERL_IS_ALIVE || !PL_curcop)
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%srealloc() %signored",
+ (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "),
+ ovp->ov_rmagic == RMAGIC - 1
+ ? "of freed memory " : "");
}
#else
- warn2("%srealloc() %signored",
- (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "),
- ovp->ov_rmagic == RMAGIC - 1 ? "of freed memory " : "");
-#endif
-#else
-#ifdef PERL_CORE
{
dTHX;
- if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
- Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s",
- "Bad realloc() ignored");
+ if (!PERL_IS_ALIVE || !PL_curcop)
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s",
+ "Bad realloc() ignored");
}
-#else
- warn("%s", "Bad realloc() ignored");
-#endif
#endif
- return Nullch; /* sanity */
+ return NULL; /* sanity */
}
onb = BUCKET_SIZE_REAL(bucket);
/*
* avoid the copy if same size block.
- * We are not agressive with boundary cases. Note that it might
+ * We are not aggressive with boundary cases. Note that it might
* (for a small number of cases) give false negative if
* both new size and old one are in the bucket for
* FIRST_BIG_POW2, but the new one is near the lower end.
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");
- FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nb - RSLOP + sizeof(u_int)),
- BUCKET_SIZE_REAL(OV_INDEX(ovp)) - (nb - RSLOP + sizeof(u_int)));
+ /* 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 + RSLOP - nbytes);
+ nb - M_OVERHEAD + RMAGIC_SZ - nbytes);
/*
* Convert amount of memory requested into
* closest block size stored in hash buckets
*/
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;
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;
}
Malloc_t
-Perl_calloc(register size_t elements, register size_t size)
+Perl_calloc(size_t elements, size_t size)
{
long sz = elements * size;
Malloc_t p = Perl_malloc(sz);
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
int
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);
Perl_mfree(var);
return 0;
}
-# endif
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);
+
+ 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. */
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 - RSLOP)) = RMAGIC;
+ *((u_int *)((caddr_t)ovp + size + M_OVERHEAD - RMAGIC_SZ)) = RMAGIC;
}
#endif
return BUCKET_SIZE_REAL(bucket);
}
+
+MEM_SIZE
+Perl_malloc_good_size(size_t wanted)
+{
+ return BUCKET_SIZE_REAL(adjust_size_and_find_bucket(&wanted));
+}
+
# ifdef BUCKETS_ROOT2
# define MIN_EVEN_REPORT 6
# else
Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level)
{
#ifdef DEBUGGING_MSTATS
- register int i, j;
- register union overhead *p;
+ int i, j;
+ 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;
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);
}
}
+#else /* defined DEBUGGING_MSTATS */
+ PerlIO_printf(Perl_error_log, "perl not compiled with DEBUGGING_MSTATS\n");
#endif /* defined DEBUGGING_MSTATS */
return 0; /* XXX unused */
}
* 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;
+ int i;
perl_mstats_t buffer;
UV nf[NBUCKETS];
UV nt[NBUCKETS];
+ PERL_ARGS_ASSERT_DUMP_MSTATS;
+
buffer.nfree = nf;
buffer.ntotal = nt;
get_mstats(&buffer, NBUCKETS, 0);
"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,
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 */
}
-#endif /* lint */
#ifdef USE_PERL_SBRK
-# if defined(__MACHTEN_PPC__) || defined(NeXT) || defined(__NeXT__) || defined(PURIFY)
+# if defined(NeXT) || defined(__NeXT__) || defined(PURIFY)
# define PERL_SBRK_VIA_MALLOC
# endif
int small, reqsize;
if (!size) return 0;
-#ifdef PERL_CORE
reqsize = size; /* just for the DEBUG_m statement */
-#endif
#ifdef PACK_MALLOC
size = (size + 0x7ff) & ~0x7ff;
#endif
}
#endif /* ! defined USE_PERL_SBRK */
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: nil
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 et:
+ */
https://perl5.git.perl.org / perl5.git / blobdiff