*
*/
+/*
+ Here are some notes on configuring Perl's malloc. (For non-perl
+ usage see below.)
+
+ 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)
+
+ # Minimal alignment (in bytes, should be a power of 2) of SYSTEM_ALLOC
+ SYSTEM_ALLOC_ALIGNMENT MEM_ALIGNBYTES
+
+ # 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).
+
+ */
+
+/*
+ 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
+
+ # Maximal value in LONG
+ LONG_MAX 0x7FFFFFFF
+
+ # Unsigned integer type big enough to keep a pointer
+ UV unsigned long
+
+ # Type of pointer with 1-byte granularity
+ caddr_t char *
+
+ # Type returned by free()
+ Free_t void
+
+ # 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)
+
+ # Error reporting function
+ warn(format, arg) 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
+ */
+
#ifndef NO_FANCY_MALLOC
# ifndef SMALL_BUCKET_VIA_TABLE
# define SMALL_BUCKET_VIA_TABLE
# ifndef TWO_POT_OPTIMIZE
# define TWO_POT_OPTIMIZE
# endif
-# if defined(PERL_CORE) && !defined(EMERGENCY_SBRK)
-# define EMERGENCY_SBRK
+# if defined(PERL_CORE) && !defined(PERL_EMERGENCY_SBRK)
+# define PERL_EMERGENCY_SBRK
# endif
# if defined(PERL_CORE) && !defined(DEBUGGING_MSTATS)
# define DEBUGGING_MSTATS
#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))
+#if !(defined(I286) || defined(atarist) || defined(__MINT__))
/* take 2k unless the block is bigger than that */
# define LOG_OF_MIN_ARENA 11
#else
* implementation, the available sizes are 2^n-4 (or 2^n-12) bytes long.
* If PACK_MALLOC is defined, small blocks are 2^n bytes long.
* This is designed for use in a program that uses vast quantities of memory,
- * but bombs when it runs out.
+ * but bombs when it runs out.
+ *
+ * Modifications Copyright Ilya Zakharevich 1996-98.
+ *
+ * Still very quick, but much more thrifty. (Std config is 10% slower
+ * 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
+ * common size=power-of-2 blocks. Running-out-of-memory is made into
+ * an exception. Deeply configurable and thread-safe.
+ *
*/
-#include "EXTERN.h"
-#include "perl.h"
-
-#ifndef PERL_CORE
+#ifdef PERL_CORE
+# include "EXTERN.h"
+# include "perl.h"
+#else
+# ifdef PERL_FOR_X2P
+# include "../EXTERN.h"
+# include "../perl.h"
+# else
+# include <stdlib.h>
+# include <stdio.h>
+# include <memory.h>
+# define _(arg) arg
+# ifndef Malloc_t
+# define Malloc_t void *
+# 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 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
+# endif
# ifndef croak /* make depend */
-# define croak(mess) fprintf(stderr,mess); exit(1);
+# define croak(mess, arg) (warn((mess), (arg)), exit(1))
+# endif
+# ifndef warn
+# define warn(mess, arg) fprintf(stderr, (mess), (arg))
# endif
# ifdef DEBUG_m
# undef DEBUG_m
# define MUTEX_UNLOCK(l)
#endif
+#ifndef MALLOC_LOCK
+# define MALLOC_LOCK MUTEX_LOCK(&PL_malloc_mutex)
+#endif
+
+#ifndef MALLOC_UNLOCK
+# define MALLOC_UNLOCK MUTEX_UNLOCK(&PL_malloc_mutex)
+#endif
+
+# ifndef fatalcroak /* make depend */
+# define fatalcroak(mess) (write(2, (mess), strlen(mess)), exit(2))
+# endif
+
#ifdef DEBUGGING
# undef DEBUG_m
-# define DEBUG_m(a) if (debug & 128) a
+# define DEBUG_m(a) if (PL_debug & 128) a
#endif
+/*
+ * Layout of memory:
+ * ~~~~~~~~~~~~~~~~
+ * The memory is broken into "blocks" which occupy multiples of 2K (and
+ * generally speaking, have size "close" to a power of 2). The addresses
+ * of such *unused* blocks are kept in nextf[i] with big enough i. (nextf
+ * is an array of linked lists.) (Addresses of used blocks are not known.)
+ *
+ * Moreover, since the algorithm may try to "bite" smaller blocks of out
+ * of unused bigger ones, there are also regions of "irregular" size,
+ * managed separately, by a linked list chunk_chain.
+ *
+ * The third type of storage is the sbrk()ed-but-not-yet-used space, its
+ * end and size are kept in last_sbrk_top and sbrked_remains.
+ *
+ * Growing blocks "in place":
+ * ~~~~~~~~~~~~~~~~~~~~~~~~~
+ * The address of the block with the greatest address is kept in last_op
+ * (if not known, last_op is 0). If it is known that the memory above
+ * last_op is not continuous, or contains a chunk from chunk_chain,
+ * last_op is set to 0.
+ *
+ * The chunk with address last_op may be grown by expanding into
+ * sbrk()ed-but-not-yet-used space, or trying to sbrk() more continuous
+ * memory.
+ *
+ * Management of last_op:
+ * ~~~~~~~~~~~~~~~~~~~~~
+ *
+ * free() never changes the boundaries of blocks, so is not relevant.
+ *
+ * The only way realloc() may change the boundaries of blocks is if it
+ * grows a block "in place". However, in the case of success such a
+ * chunk is automatically last_op, and it remains last_op. In the case
+ * of failure getpages_adjacent() clears last_op.
+ *
+ * malloc() may change blocks by calling morecore() only.
+ *
+ * morecore() may create new blocks by:
+ * a) biting pieces from chunk_chain (cannot create one above last_op);
+ * b) biting a piece from an unused block (if block was last_op, this
+ * may create a chunk from chain above last_op, thus last_op is
+ * invalidated in such a case).
+ * c) biting of sbrk()ed-but-not-yet-used space. This creates
+ * a block which is last_op.
+ * d) Allocating new pages by calling getpages();
+ *
+ * getpages() creates a new block. It marks last_op at the bottom of
+ * the chunk of memory it returns.
+ *
+ * Active pages footprint:
+ * ~~~~~~~~~~~~~~~~~~~~~~
+ * Note that we do not need to traverse the lists in nextf[i], just take
+ * the first element of this list. However, we *need* to traverse the
+ * list in chunk_chain, but most the time it should be a very short one,
+ * so we do not step on a lot of pages we are not going to use.
+ *
+ * Flaws:
+ * ~~~~~
+ * get_from_bigger_buckets(): forget to increment price => Quite
+ * aggressive.
+ */
+
/* I don't much care whether these are defined in sys/types.h--LAW */
#define u_char unsigned char
#define u_short unsigned short
/* 286 and atarist like big chunks, which gives too much overhead. */
-#if (defined(RCHECK) || defined(I286) || defined(atarist)) && defined(PACK_MALLOC)
+#if (defined(RCHECK) || defined(I286) || defined(atarist) || defined(__MINT__)) && defined(PACK_MALLOC)
# undef PACK_MALLOC
#endif
};
#ifdef DEBUGGING
-static void botch _((char *s));
+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 */
# 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] =
# endif
};
+# define NEEDED_ALIGNMENT 0x800 /* 2k boundaries */
+# define WANTED_ALIGNMENT 0x800 /* 2k boundaries */
+
#else /* !PACK_MALLOC */
# define OV_MAGIC(block,bucket) (block)->ov_magic
# define OV_INDEX(block) (block)->ov_index
# define CHUNK_SHIFT 1
# define MAX_PACKED -1
+# define NEEDED_ALIGNMENT MEM_ALIGNBYTES
+# define WANTED_ALIGNMENT 0x400 /* 1k boundaries */
+
#endif /* !PACK_MALLOC */
#define M_OVERHEAD (sizeof(union overhead) + RSLOP)
/* 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 */
#endif
#ifndef FIRST_SBRK
-# define FIRST_SBRK (32*1024)
+# define FIRST_SBRK (48*1024)
#endif
/* Minimal sbrk in percents of what is already alloced. */
# define BIG_SIZE (1<<16) /* 64K */
# endif
+#ifdef I_MACH_CTHREADS
+# undef MUTEX_LOCK
+# define MUTEX_LOCK(m) STMT_START { if (*m) mutex_lock(*m); } STMT_END
+# undef MUTEX_UNLOCK
+# define MUTEX_UNLOCK(m) STMT_START { if (*m) mutex_unlock(*m); } STMT_END
+#endif
+
static char *emergency_buffer;
static MEM_SIZE emergency_buffer_size;
+static Malloc_t emergency_sbrk(MEM_SIZE size);
static Malloc_t
-emergency_sbrk(size)
- MEM_SIZE size;
+emergency_sbrk(MEM_SIZE size)
{
+ MEM_SIZE rsize = (((size - 1)>>LOG_OF_MIN_ARENA) + 1)<<LOG_OF_MIN_ARENA;
+
if (size >= BIG_SIZE) {
/* Give the possibility to recover: */
- die("Out of memory during request for %i bytes", size);
- /* croak may eat too much memory. */
+ MALLOC_UNLOCK;
+ 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;
-
- if (!gvp) gvp = (GV**)hv_fetch(defstash, "\015", 1, 0);
+ int have = 0;
+ STRLEN n_a;
+
+ 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<<LOG_OF_MIN_ARENA) - M_OVERHEAD))
+ || (SvLEN(sv) < (1<<LOG_OF_MIN_ARENA) - M_OVERHEAD)) {
+ if (have)
+ goto do_croak;
return (char *)-1; /* Now die die die... */
-
+ }
/* Got it, now detach SvPV: */
- pv = SvPV(sv, na);
+ pv = SvPV(sv, n_a);
/* Check alignment: */
- if (((u_bigint)(pv - M_OVERHEAD)) & ((1<<LOG_OF_MIN_ARENA) - 1)) {
+ if (((UV)(pv - sizeof(union overhead))) & (NEEDED_ALIGNMENT - 1)) {
PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n");
return (char *)-1; /* die die die */
}
- emergency_buffer = pv - M_OVERHEAD;
- emergency_buffer_size = SvLEN(sv) + M_OVERHEAD;
+ emergency_buffer = pv - sizeof(union overhead);
+ emergency_buffer_size = malloced_size(pv) + M_OVERHEAD;
SvPOK_off(sv);
- SvREADONLY_on(sv);
- die("Out of memory!"); /* croak may eat too much memory. */
- }
- else if (emergency_buffer_size >= 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:
+ MALLOC_UNLOCK;
+ croak("Out of memory during request for %i bytes", size);
}
#else /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */
static u_int goodsbrk;
#ifdef DEBUGGING
-#define ASSERT(p) if (!(p)) botch(STRINGIFY(p)); else
+#undef ASSERT
+#define ASSERT(p,diag) if (!(p)) botch(diag,STRINGIFY(p)); else
static void
-botch(char *s)
+botch(char *diag, char *s)
{
- PerlIO_printf(PerlIO_stderr(), "assertion botched: %s\n", s);
+ PerlIO_printf(PerlIO_stderr(), "assertion botched (%s?): %s\n", diag, s);
PerlProc_abort();
}
#else
-#define ASSERT(p)
+#define ASSERT(p, diag)
#endif
Malloc_t
-malloc(register size_t nbytes)
+Perl_malloc(register size_t nbytes)
{
register union overhead *p;
register int bucket;
BARK_64K_LIMIT("Allocation",nbytes,nbytes);
#ifdef DEBUGGING
if ((long)nbytes < 0)
- croak("panic: malloc");
+ croak("%s", "panic: malloc");
#endif
- MUTEX_LOCK(&malloc_mutex);
+ MALLOC_LOCK;
/*
* Convert amount of memory requested into
* closest block size stored in hash buckets
if (nextf[bucket] == NULL)
morecore(bucket);
if ((p = nextf[bucket]) == NULL) {
- MUTEX_UNLOCK(&malloc_mutex);
+ MALLOC_UNLOCK;
#ifdef PERL_CORE
- if (!nomemok) {
+ if (!PL_nomemok) {
PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
my_exit(1);
}
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
*((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
}
#endif
- MUTEX_UNLOCK(&malloc_mutex);
+ MALLOC_UNLOCK;
return ((Malloc_t)(p + CHUNK_SHIFT));
}
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);
+ 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;
+
+#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 ((UV)cp & (WANTED_ALIGNMENT - 1)) { /* Not aligned. */
+ slack = WANTED_ALIGNMENT - ((UV)cp & (WANTED_ALIGNMENT - 1));
+ add += slack;
+ }
+# endif
+#endif /* !atarist && !MINT */
+
+ 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) {
+ 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_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.
+ */
+
+# if NEEDED_ALIGNMENT > MEM_ALIGNBYTES
+ if ((UV)ovp & (NEEDED_ALIGNMENT - 1))
+ fatalcroak("Misalignment of sbrk()\n");
+ else
+# endif
+#ifndef I286 /* Again, this should always be ok on an 80286 */
+ if ((UV)ovp & (MEM_ALIGNBYTES - 1)) {
+ DEBUG_m(PerlIO_printf(Perl_debug_log,
+ "fixing sbrk(): %d bytes off machine alignement\n",
+ (int)((UV)ovp & (MEM_ALIGNBYTES - 1))));
+ ovp = (union overhead *)(((UV)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
+ }
+#endif
+ ; /* Finish `else' */
+ sbrked_remains = require - needed;
+ last_op = cp;
+ }
+ last_sbrk_top = cp + require;
+#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.
*/
{
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) {
- croak("Allocation too large");
+ MALLOC_UNLOCK;
+ croak("%s", "Out of memory during ridiculously large request");
}
-
- if (bucket > max_bucket) {
+ if (bucket > max_bucket)
max_bucket = bucket;
- }
+
rnu = ( (bucket <= (LOG_OF_MIN_ARENA << BUCKET_POW2_SHIFT))
? LOG_OF_MIN_ARENA
: (bucket >> BUCKET_POW2_SHIFT) );
DEBUG_m(PerlIO_printf(Perl_debug_log,
"stealing %ld bytes from chain\n",
(long) needed));
- } else if (ovp = (union overhead*)
- get_from_bigger_buckets((rnu << BUCKET_POW2_SHIFT) + 1,
- needed)) {
+ } else if ( (ovp = (union overhead*)
+ get_from_bigger_buckets((rnu << BUCKET_POW2_SHIFT) + 1,
+ needed)) ) {
DEBUG_m(PerlIO_printf(Perl_debug_log,
"stealing %ld bytes from bigger buckets\n",
(long) needed));
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)
- croak("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.
}
Free_t
-free(void *mp)
+Perl_mfree(void *mp)
{
register MEM_SIZE size;
register union overhead *ovp;
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;
warn("%s free() ignored",
ovp->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
#else
- warn("Bad free() ignored");
+ warn("%s", "Bad free() ignored");
#endif
return; /* sanity */
}
- MUTEX_LOCK(&malloc_mutex);
+ MALLOC_LOCK;
#ifdef RCHECK
- ASSERT(ovp->ov_rmagic == RMAGIC);
+ ASSERT(ovp->ov_rmagic == RMAGIC, "chunk's head overwrite");
if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) {
int i;
MEM_SIZE nbytes = ovp->ov_size + 1;
i = 4 - i;
while (i--) {
ASSERT(*((char *)((caddr_t)ovp + nbytes - RSLOP + i))
- == RMAGIC_C);
+ == RMAGIC_C, "chunk's tail overwrite");
}
}
nbytes = (nbytes + 3) &~ 3;
- ASSERT(*(u_int *)((caddr_t)ovp + nbytes - RSLOP) == RMAGIC);
+ ASSERT(*(u_int *)((caddr_t)ovp + nbytes - RSLOP) == RMAGIC, "chunk's tail overwrite");
}
ovp->ov_rmagic = RMAGIC - 1;
#endif
- ASSERT(OV_INDEX(ovp) < NBUCKETS);
+ ASSERT(OV_INDEX(ovp) < NBUCKETS, "chunk's head overwrite");
size = OV_INDEX(ovp);
ovp->ov_next = nextf[size];
nextf[size] = ovp;
- MUTEX_UNLOCK(&malloc_mutex);
+ MALLOC_UNLOCK;
}
/*
* is extern so the caller can modify it). If that fails we just copy
* however many bytes was given to realloc() and hope it's not huge.
*/
-int reall_srchlen = 4; /* 4 should be plenty, -1 =>'s whole list */
+#define reall_srchlen 4 /* 4 should be plenty, -1 =>'s whole list */
Malloc_t
-realloc(void *mp, size_t nbytes)
+Perl_realloc(void *mp, size_t nbytes)
{
register MEM_SIZE onb;
union overhead *ovp;
- char *res, prev_bucket;
+ char *res;
+ int prev_bucket;
register int bucket;
int was_alloced = 0, incr;
char *cp = (char*)mp;
MEM_SIZE size = nbytes;
if ((long)nbytes < 0)
- croak("panic: realloc");
+ croak("%s", "panic: realloc");
#endif
BARK_64K_LIMIT("Reallocation",nbytes,size);
if (!cp)
- return malloc(nbytes);
+ return Perl_malloc(nbytes);
- MUTEX_LOCK(&malloc_mutex);
+ MALLOC_LOCK;
ovp = (union overhead *)((caddr_t)cp
- sizeof (union overhead) * CHUNK_SHIFT);
bucket = OV_INDEX(ovp);
#endif
) goto hard_way;
else if (incr == 0) {
- inplace:
+ inplace_label:
#ifdef RCHECK
/*
* Record new allocated size of block and
if ((i = nb & 3)) {
i = 4 - i;
while (i--) {
- ASSERT(*((char *)((caddr_t)ovp + nb - RSLOP + i)) == RMAGIC_C);
+ ASSERT(*((char *)((caddr_t)ovp + nb - RSLOP + i)) == RMAGIC_C, "chunk's tail overwrite");
}
}
nb = (nb + 3) &~ 3;
- ASSERT(*(u_int *)((caddr_t)ovp + nb - RSLOP) == RMAGIC);
+ ASSERT(*(u_int *)((caddr_t)ovp + nb - RSLOP) == RMAGIC, "chunk's tail overwrite");
/*
* Convert amount of memory requested into
* closest block size stored in hash buckets
}
#endif
res = cp;
- MUTEX_UNLOCK(&malloc_mutex);
+ MALLOC_UNLOCK;
+ 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;
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);
+ if (getpages_adjacent(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;
- }
- }
-
-#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;
+ *(cp - M_OVERHEAD) = pow * BUCKETS_PER_POW2; /* Fill index. */
+ goto inplace_label;
+ } else
+ goto hard_way;
} else {
hard_way:
- MUTEX_UNLOCK(&malloc_mutex);
- if ((res = (char*)malloc(nbytes)) == NULL)
+ MALLOC_UNLOCK;
+ 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*)Perl_malloc(nbytes)) == NULL)
return (NULL);
if (cp != res) /* common optimization */
Copy(cp, res, (MEM_SIZE)(nbytes<onb?nbytes:onb), char);
if (was_alloced)
- free(cp);
+ Perl_mfree(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);
}
}
Malloc_t
-calloc(register size_t elements, register size_t size)
+Perl_calloc(register size_t elements, register size_t size)
{
long sz = elements * size;
- Malloc_t p = malloc(sz);
+ Malloc_t p = Perl_malloc(sz);
if (p) {
memset((void*)p, 0, sz);
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);
}
}
if (s)
PerlIO_printf(PerlIO_stderr(),
- "Memory allocation statistics %s (buckets %d(%d)..%d(%d)\n",
+ "Memory allocation statistics %s (buckets %ld(%ld)..%ld(%ld)\n",
s,
- BUCKET_SIZE_REAL(MIN_BUCKET),
- BUCKET_SIZE(MIN_BUCKET),
- BUCKET_SIZE_REAL(topbucket), BUCKET_SIZE(topbucket));
+ (long)BUCKET_SIZE_REAL(MIN_BUCKET),
+ (long)BUCKET_SIZE(MIN_BUCKET),
+ (long)BUCKET_SIZE_REAL(topbucket), (long)BUCKET_SIZE(topbucket));
PerlIO_printf(PerlIO_stderr(), "%8d free:", totfree);
for (i = MIN_EVEN_REPORT; i <= topbucket; i += BUCKETS_PER_POW2) {
PerlIO_printf(PerlIO_stderr(),
#ifdef USE_PERL_SBRK
-# ifdef NeXT
+# if defined(__MACHTEN_PPC__) || defined(__NeXT__)
# 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 <domo@computer.org>
+ */
+# define SYSTEM_ALLOC_ALIGNMENT 2
# endif
# ifdef PERL_SBRK_VIA_MALLOC
-# if defined(HIDEMYMALLOC) || defined(EMBEDMYMALLOC)
-# undef malloc
-# else
-# include "Error: -DPERL_SBRK_VIA_MALLOC needs -D(HIDE|EMBED)MYMALLOC"
-# endif
/* it may seem schizophrenic to use perl's malloc and let it call system */
/* malloc, the reason for that is only the 3.2 version of the OS that had */
/* 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
+# ifndef SYSTEM_ALLOC_ALIGNMENT
+# define SYSTEM_ALLOC_ALIGNMENT MEM_ALIGNBYTES
+# endif
# endif /* PERL_SBRK_VIA_MALLOC */
# define PERLSBRK_64_K (1<<16)
Malloc_t
-Perl_sbrk(size)
-int size;
+Perl_sbrk(int size)
{
IV got;
int small, reqsize;
size = PERLSBRK_64_K;
small = 1;
}
+# if NEEDED_ALIGNMENT > SYSTEM_ALLOC_ALIGNMENT
+ size += NEEDED_ALIGNMENT - SYSTEM_ALLOC_ALIGNMENT;
+# endif
got = (IV)SYSTEM_ALLOC(size);
-#ifdef PACK_MALLOC
- got = (got + 0x7ff) & ~0x7ff;
-#endif
+# if NEEDED_ALIGNMENT > SYSTEM_ALLOC_ALIGNMENT
+ got = (got + NEEDED_ALIGNMENT - 1) & (NEEDED_ALIGNMENT - 1);
+# endif
if (small) {
/* Chunk is small, register the rest for future allocs. */
Perl_sbrk_oldchunk = got + reqsize;
projects / p5sagit/p5-mst-13.2.git / blobdiff