*/
/*
+ * "'The Chamber of Records,' said Gimli. 'I guess that is where we now stand.'"
+ */
+
+/*
Here are some notes on configuring Perl's malloc. (For non-perl
usage see below.)
# 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)
# 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
+# define croak2 croak
+# define warn2 warn
# endif
#else
# ifdef PERL_FOR_X2P
# include <stdlib.h>
# include <stdio.h>
# include <memory.h>
-# define _(arg) arg
# ifndef Malloc_t
# define Malloc_t void *
# 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) fprintf(stderr, (mess), (arg1), (arg2))
+# endif
# ifdef DEBUG_m
# undef DEBUG_m
# endif
# ifndef pTHX
# define pTHX void
# define pTHX_
-# define dTHX extern int Perl___notused
+# 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
# undef DEBUG_m
# define DEBUG_m(a) \
STMT_START { \
- if (PERL_GET_INTERP) { dTHX; if (PL_debug & 128) { a; } } \
+ if (PERL_GET_INTERP) { dTHX; if (DEBUG_m_TEST) { a; } } \
} STMT_END
#endif
double strut; /* alignment problems */
#endif
struct {
+/*
+ * Keep the ovu_index and ovu_magic in this order, having a char
+ * field first gives alignment indigestion in some systems, such as
+ * MachTen.
+ */
u_char ovu_index; /* bucket # */
u_char ovu_magic; /* magic number */
#ifdef RCHECK
static union overhead *getpages (MEM_SIZE needed, int *nblksp, int bucket);
static int getpages_adjacent(MEM_SIZE require);
-#if defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)
-
-# ifndef BIG_SIZE
-# define BIG_SIZE (1<<16) /* 64K */
-# endif
+#ifdef PERL_CORE
#ifdef I_MACH_CTHREADS
# undef MUTEX_LOCK
# define MUTEX_UNLOCK(m) STMT_START { if (*m) mutex_unlock(*m); } STMT_END
#endif
+#ifndef BITS_IN_PTR
+# define BITS_IN_PTR (8*PTRSIZE)
+#endif
+
+/*
+ * nextf[i] is the pointer to the next free block of size 2^i. The
+ * smallest allocatable block is 8 bytes. The overhead information
+ * precedes the data area returned to the user.
+ */
+#define NBUCKETS (BITS_IN_PTR*BUCKETS_PER_POW2 + 1)
+static union overhead *nextf[NBUCKETS];
+
+#if defined(PURIFY) && !defined(USE_PERL_SBRK)
+# define USE_PERL_SBRK
+#endif
+
+#ifdef USE_PERL_SBRK
+# define sbrk(a) Perl_sbrk(a)
+Malloc_t Perl_sbrk (int size);
+#else
+# ifndef HAS_SBRK_PROTO /* <unistd.h> usually takes care of this */
+extern Malloc_t sbrk(int);
+# endif
+#endif
+
+#ifdef DEBUGGING_MSTATS
+/*
+ * nmalloc[i] is the difference between the number of mallocs and frees
+ * for a given block size.
+ */
+static u_int nmalloc[NBUCKETS];
+static u_int sbrk_slack;
+static u_int start_slack;
+#else /* !( defined DEBUGGING_MSTATS ) */
+# define sbrk_slack 0
+#endif
+
+static u_int goodsbrk;
+
+# ifdef PERL_EMERGENCY_SBRK
+
+# ifndef BIG_SIZE
+# define BIG_SIZE (1<<16) /* 64K */
+# endif
+
static char *emergency_buffer;
static MEM_SIZE emergency_buffer_size;
+static int no_mem; /* 0 if the last request for more memory succeeded.
+ Otherwise the size of the failing request. */
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) {
- /* Give the possibility to recover: */
+ if (size >= BIG_SIZE && (!no_mem || (size < no_mem))) {
+ /* Give the possibility to recover, but avoid an infinite cycle. */
MALLOC_UNLOCK;
- croak("Out of memory during \"large\" request for %i bytes", size);
+ no_mem = size;
+ croak2("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) {
}
do_croak:
MALLOC_UNLOCK;
- croak("Out of memory during request for %i bytes", size);
+ 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) && defined(PERL_CORE)) */
+# else /* !defined(PERL_EMERGENCY_SBRK) */
# define emergency_sbrk(size) -1
-#endif /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */
-
-#ifndef BITS_IN_PTR
-# define BITS_IN_PTR (8*PTRSIZE)
-#endif
-
-/*
- * nextf[i] is the pointer to the next free block of size 2^i. The
- * smallest allocatable block is 8 bytes. The overhead information
- * precedes the data area returned to the user.
- */
-#define NBUCKETS (BITS_IN_PTR*BUCKETS_PER_POW2 + 1)
-static union overhead *nextf[NBUCKETS];
-
-#if defined(PURIFY) && !defined(USE_PERL_SBRK)
-# define USE_PERL_SBRK
-#endif
-
-#ifdef USE_PERL_SBRK
-#define sbrk(a) Perl_sbrk(a)
-Malloc_t Perl_sbrk (int size);
-#else
-#ifdef DONT_DECLARE_STD
-#ifdef I_UNISTD
-#include <unistd.h>
-#endif
-#else
-extern Malloc_t sbrk(int);
-#endif
-#endif
-
-#ifdef DEBUGGING_MSTATS
-/*
- * nmalloc[i] is the difference between the number of mallocs and frees
- * for a given block size.
- */
-static u_int nmalloc[NBUCKETS];
-static u_int sbrk_slack;
-static u_int start_slack;
-#endif
-
-static u_int goodsbrk;
+# endif
+#endif /* ifdef PERL_CORE */
#ifdef DEBUGGING
#undef ASSERT
POW2_OPTIMIZE_ADJUST(nbytes);
nbytes += M_OVERHEAD;
nbytes = (nbytes + 3) &~ 3;
+#if defined(PACK_MALLOC) && !defined(SMALL_BUCKET_VIA_TABLE)
do_shifts:
+#endif
shiftr = (nbytes - 1) >> START_SHIFT;
bucket = START_SHIFTS_BUCKET;
/* apart from this loop, this is O(1) */
{
dTHX;
if (!PL_nomemok) {
- PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
+#if defined(PLAIN_MALLOC) && defined(NO_FANCY_MALLOC)
+ PerlIO_puts(PerlIO_stderr(),"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 ");
+#if defined(DEBUGGING) || defined(RCHECK)
+ n = size;
+#endif
+ *s = 0;
+ do {
+ *--s = '0' + (n % 10);
+ } while (n /= 10);
+ PerlIO_puts(PerlIO_stderr(),s);
+ PerlIO_puts(PerlIO_stderr()," 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");
+#endif /* defined(PLAIN_MALLOC) && defined(NO_FANCY_MALLOC) */
my_exit(1);
}
}
DEBUG_m(PerlIO_printf(Perl_debug_log,
"0x%"UVxf": (%05lu) malloc %ld bytes\n",
- PTR2UV(p+1), (unsigned long)(PL_an++),
+ PTR2UV(p), (unsigned long)(PL_an++),
(long)size));
/* remove from linked list */
sbrked_remains = require - needed;
last_op = cp;
}
+#if !defined(PLAIN_MALLOC) && !defined(NO_FANCY_MALLOC)
+ no_mem = 0;
+#endif
last_sbrk_top = cp + require;
#ifdef DEBUGGING_MSTATS
goodsbrk += require;
{
dTHX;
if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
- Perl_warner(aTHX_ WARN_MALLOC, "%s free() ignored",
+ Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s free() ignored (RMAGIC, PERL_CORE)",
ovp->ov_rmagic == RMAGIC - 1 ?
"Duplicate" : "Bad");
}
#else
- warn("%s free() ignored",
+ warn("%s free() ignored (RMAGIC)",
ovp->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
#endif
#else
{
dTHX;
if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
- Perl_warner(aTHX_ WARN_MALLOC, "%s", "Bad free() ignored");
+ Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s", "Bad free() ignored (PERL_CORE)");
}
#else
warn("%s", "Bad free() ignored");
{
dTHX;
if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
- Perl_warner(aTHX_ WARN_MALLOC, "%srealloc() %signored",
+ Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%srealloc() %signored",
(ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "),
ovp->ov_rmagic == RMAGIC - 1
? "of freed memory " : "");
{
dTHX;
if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
- Perl_warner(aTHX_ WARN_MALLOC, "%s",
+ Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s",
"Bad realloc() ignored");
}
#else
https://perl5.git.perl.org / perl5.git / blobdiff