# 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
* but bombs when it runs out.
*/
-#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
};
#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));
#endif
#ifndef FIRST_SBRK
-# define FIRST_SBRK (32*1024)
+# define FIRST_SBRK (48*1024)
#endif
/* Minimal sbrk in percents of what is already alloced. */
{
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. */
+ MUTEX_UNLOCK(&malloc_mutex);
+ croak("Out of memory during request for %i bytes", size);
}
if (!emergency_buffer) {
emergency_buffer_size = SvLEN(sv) + M_OVERHEAD;
SvPOK_off(sv);
SvREADONLY_on(sv);
- die("Out of memory!"); /* croak may eat too much memory. */
+ MUTEX_UNLOCK(&malloc_mutex);
+ croak("Out of memory during request for %i bytes", size);
}
else if (emergency_buffer_size >= size) {
emergency_buffer_size -= size;
static u_int goodsbrk;
#ifdef DEBUGGING
-#define ASSERT(p) if (!(p)) botch(STRINGIFY(p)); else
+#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
BARK_64K_LIMIT("Allocation",nbytes,nbytes);
#ifdef DEBUGGING
if ((long)nbytes < 0)
- croak("panic: malloc");
+ croak("%s", "panic: malloc");
#endif
MUTEX_LOCK(&malloc_mutex);
if (nextf[bucket])
return;
if (bucket == sizeof(MEM_SIZE)*8*BUCKETS_PER_POW2) {
- croak("Allocation too large");
+ MUTEX_UNLOCK(&malloc_mutex);
+ 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));
DEBUG_m(PerlIO_printf(Perl_debug_log,
"failed to fix bad sbrk()\n"));
#ifdef PACK_MALLOC
- if (slack)
- croak("panic: Off-page sbrk");
+ if (slack) {
+ MUTEX_UNLOCK(&malloc_mutex);
+ croak("%s", "panic: Off-page sbrk");
+ }
#endif
if (sbrked_remains) {
/* Try again. */
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);
#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;
{
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 ((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
}
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(),
projects / p5sagit/p5-mst-13.2.git / commitdiff