# Use table lookup to decide in which bucket a given allocation will go.
SMALL_BUCKET_VIA_TABLE !NO_FANCY_MALLOC
- # Use system-malloc() to emulate sbrk(). Normally only used with broken
- # sbrk()s.
+ # 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)
+
# Disable memory overwrite checking with DEBUGGING. Memory and speed
# optimization, error reporting pessimization.
NO_RCHECK undef
# This many continuous sbrk()s compensate for one discontinuous one.
SBRK_FAILURE_PRICE 50
- # Which allocator to use if PERL_SBRK_VIA_MALLOC
- SYSTEM_ALLOC(a) malloc(a)
+ # 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).
#ifdef DEBUGGING
# undef DEBUG_m
-# define DEBUG_m(a) if (debug & 128) a
+# define DEBUG_m(a) if (PL_debug & 128) a
#endif
/* I don't much care whether these are defined in sys/types.h--LAW */
#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] =
/* 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 */
emergency_sbrk(size)
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: */
- MUTEX_UNLOCK(&malloc_mutex);
+ MUTEX_UNLOCK(&PL_malloc_mutex);
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;
+ int have = 0;
- if (!gvp) gvp = (GV**)hv_fetch(defstash, "\015", 1, 0);
+ 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, PL_na);
/* Check alignment: */
- if (((u_bigint)(pv - M_OVERHEAD)) & ((1<<LOG_OF_MIN_ARENA) - 1)) {
+ if (((UV)(pv - sizeof(union overhead))) & ((1<<LOG_OF_MIN_ARENA) - 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);
- MUTEX_UNLOCK(&malloc_mutex);
- croak("Out of memory during request for %i bytes", size);
- }
- 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:
+ MUTEX_UNLOCK(&PL_malloc_mutex);
+ croak("Out of memory during request for %i bytes", size);
}
#else /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */
croak("%s", "panic: malloc");
#endif
- MUTEX_LOCK(&malloc_mutex);
+ MUTEX_LOCK(&PL_malloc_mutex);
/*
* 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);
+ MUTEX_UNLOCK(&PL_malloc_mutex);
#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);
+ MUTEX_UNLOCK(&PL_malloc_mutex);
return ((Malloc_t)(p + CHUNK_SHIFT));
}
"failed to fix bad sbrk()\n"));
#ifdef PACK_MALLOC
if (slack) {
- MUTEX_UNLOCK(&malloc_mutex);
+ MUTEX_UNLOCK(&PL_malloc_mutex);
croak("%s", "panic: Off-page sbrk");
}
#endif
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),
if (nextf[bucket])
return;
if (bucket == sizeof(MEM_SIZE)*8*BUCKETS_PER_POW2) {
- MUTEX_UNLOCK(&malloc_mutex);
+ MUTEX_UNLOCK(&PL_malloc_mutex);
croak("%s", "Out of memory during ridiculously large request");
}
if (bucket > max_bucket)
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;
#endif
return; /* sanity */
}
- MUTEX_LOCK(&malloc_mutex);
+ MUTEX_LOCK(&PL_malloc_mutex);
#ifdef RCHECK
ASSERT(ovp->ov_rmagic == RMAGIC, "chunk's head overwrite");
if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) {
size = OV_INDEX(ovp);
ovp->ov_next = nextf[size];
nextf[size] = ovp;
- MUTEX_UNLOCK(&malloc_mutex);
+ MUTEX_UNLOCK(&PL_malloc_mutex);
}
/*
if (!cp)
return malloc(nbytes);
- MUTEX_LOCK(&malloc_mutex);
+ MUTEX_LOCK(&PL_malloc_mutex);
ovp = (union overhead *)((caddr_t)cp
- sizeof (union overhead) * CHUNK_SHIFT);
bucket = OV_INDEX(ovp);
}
#endif
res = cp;
- MUTEX_UNLOCK(&malloc_mutex);
+ MUTEX_UNLOCK(&PL_malloc_mutex);
+ 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;
goto hard_way;
} else {
hard_way:
- MUTEX_UNLOCK(&malloc_mutex);
+ MUTEX_UNLOCK(&PL_malloc_mutex);
+ 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*)malloc(nbytes)) == NULL)
return (NULL);
if (cp != res) /* common optimization */
if (was_alloced)
free(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);
}
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);
}
# define PERL_SBRK_VIA_MALLOC
# endif
+# ifdef __MACHTEN_PPC__
+# 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(a) ((void *)(((unsigned)malloc((a)+6)+6)&~7))
+# endif
+
# ifdef PERL_SBRK_VIA_MALLOC
# if defined(HIDEMYMALLOC) || defined(EMBEDMYMALLOC)
-# undef malloc
+# undef malloc /* Expose names that */
+# undef calloc /* HIDEMYMALLOC hides */
+# undef realloc
+# undef free
# else
# include "Error: -DPERL_SBRK_VIA_MALLOC needs -D(HIDE|EMBED)MYMALLOC"
# endif
/* 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
# endif /* PERL_SBRK_VIA_MALLOC */
projects / p5sagit/p5-mst-13.2.git / blobdiff