# 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
# 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)
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)
+ MALLOC_LOCK MUTEX_LOCK_NOCONTEXT(&PL_malloc_mutex)
+ MALLOC_UNLOCK MUTEX_UNLOCK_NOCONTEXT(&PL_malloc_mutex)
# Locking/unlocking mutex for MT operation
MUTEX_LOCK(l) void
#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
* This is designed for use in a program that uses vast quantities of memory,
* but bombs when it runs out.
*
- * Modifications Copyright Ilya Zakharevich 1996-98.
+ * Modifications Copyright Ilya Zakharevich 1996-99.
*
* 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.)
#ifdef PERL_CORE
# include "EXTERN.h"
+#define PERL_IN_MALLOC_C
# include "perl.h"
+# if defined(PERL_IMPLICIT_CONTEXT)
+# define croak Perl_croak_nocontext
+# define warn Perl_warn_nocontext
+# endif
#else
# ifdef PERL_FOR_X2P
# include "../EXTERN.h"
# ifdef DEBUGGING
# undef DEBUGGING
# endif
+# ifndef pTHX
+# define pTHX void
+# define pTHX_
+# define dTHX extern int Perl___notused
+# define WITH_THX(s) s
+# endif
+# ifndef PERL_GET_INTERP
+# define PERL_GET_INTERP PL_curinterp
+# endif
#endif
#ifndef MUTEX_LOCK
#endif
#ifndef MALLOC_LOCK
-# define MALLOC_LOCK MUTEX_LOCK(PL_malloc_mutex)
+# define MALLOC_LOCK MUTEX_LOCK_NOCONTEXT(&PL_malloc_mutex)
#endif
#ifndef MALLOC_UNLOCK
-# define MALLOC_UNLOCK MUTEX_UNLOCK(PL_malloc_mutex)
+# define MALLOC_UNLOCK MUTEX_UNLOCK_NOCONTEXT(&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 (PL_debug & 128) a
+# define DEBUG_m(a) if (PERL_GET_INTERP && PL_debug & 128) a
#endif
/*
#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
#define ov_rmagic ovu.ovu_rmagic
};
-#ifdef DEBUGGING
-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 RMAGIC_C 0x55 /* magic # on range info */
# 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)
static char *emergency_buffer;
static MEM_SIZE emergency_buffer_size;
-static Malloc_t emergency_sbrk(MEM_SIZE size);
+
+static int findbucket (union overhead *freep, int srchlen);
+static void morecore (register int bucket);
+# if defined(DEBUGGING)
+static void botch (char *diag, char *s);
+# endif
+static void add_to_chain (void *p, MEM_SIZE size, MEM_SIZE chip);
+static Malloc_t emergency_sbrk (MEM_SIZE size);
+static void* get_from_chain (MEM_SIZE size);
+static void* get_from_bigger_buckets(int bucket, MEM_SIZE size);
+static union overhead *getpages (int needed, int *nblksp, int bucket);
+static int getpages_adjacent(int require);
static Malloc_t
emergency_sbrk(MEM_SIZE size)
emergency_buffer += rsize;
return old;
} else {
- dTHR;
+ 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;
int have = 0;
+ STRLEN n_a;
if (emergency_buffer_size) {
add_to_chain(emergency_buffer, emergency_buffer_size, 0);
return (char *)-1; /* Now die die die... */
}
/* Got it, now detach SvPV: */
- pv = SvPV(sv, PL_na);
+ pv = SvPV(sv, n_a);
/* Check alignment: */
- if (((UV)(pv - sizeof(union 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 */
}
#ifdef USE_PERL_SBRK
#define sbrk(a) Perl_sbrk(a)
-Malloc_t Perl_sbrk _((int size));
+Malloc_t Perl_sbrk (int size);
#else
#ifdef DONT_DECLARE_STD
#ifdef I_UNISTD
#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("%s", "panic: malloc");
+ croak("%s", "panic: malloc");
#endif
MALLOC_LOCK;
#ifdef PERL_CORE
if (!PL_nomemok) {
PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
- my_exit(1);
+ WITH_THX(my_exit(1));
}
#else
return (NULL);
/* Second, check alignment. */
slack = 0;
-#ifndef atarist /* on the atari we dont have to worry about this */
+#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 */
-
- /* 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));
+ /* 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 */
+#endif /* !atarist && !MINT */
if (add) {
DEBUG_m(PerlIO_printf(Perl_debug_log,
#ifdef PACK_MALLOC
if (slack) {
MALLOC_UNLOCK;
- croak("%s", "panic: Off-page sbrk");
+ fatalcroak("panic: Off-page sbrk\n");
}
#endif
if (sbrked_remains) {
* 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 & 7) {
- ovp = (union overhead *)(((UV)ovp + 8) & ~7);
+ if ((UV)ovp & (MEM_ALIGNBYTES - 1)) {
DEBUG_m(PerlIO_printf(Perl_debug_log,
"fixing sbrk(): %d bytes off machine alignement\n",
- (int)((UV)ovp & 7)));
+ (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);
+ sbrk_slack += (1 << (bucket >> BUCKET_POW2_SHIFT));
# endif
}
#endif
+ ; /* Finish `else' */
sbrked_remains = require - needed;
last_op = cp;
}
}
Free_t
-free(void *mp)
-{
+Perl_mfree(void *mp)
+{
register MEM_SIZE size;
register union overhead *ovp;
char *cp = (char*)mp;
#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;
MEM_SIZE size = nbytes;
if ((long)nbytes < 0)
- croak("%s", "panic: realloc");
+ croak("%s", "panic: realloc");
#endif
BARK_64K_LIMIT("Reallocation",nbytes,size);
if (!cp)
- return malloc(nbytes);
+ return Perl_malloc(nbytes);
MALLOC_LOCK;
ovp = (union overhead *)((caddr_t)cp
"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)
+ 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);
}
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)
+Perl_malloced_size(void *p)
{
union overhead *ovp = (union overhead *)
((caddr_t)p - sizeof (union overhead) * CHUNK_SHIFT);
return BUCKET_SIZE_REAL(bucket);
}
-#ifdef DEBUGGING_MSTATS
-
# ifdef BUCKETS_ROOT2
# define MIN_EVEN_REPORT 6
# else
* frees for each size category.
*/
void
-dump_mstats(char *s)
+Perl_dump_mstats(pTHX_ char *s)
{
+#ifdef DEBUGGING_MSTATS
register int i, j;
register union overhead *p;
int topbucket=0, topbucket_ev=0, topbucket_odd=0, totfree=0, total=0;
PerlIO_printf(PerlIO_stderr(), "\nTotal sbrk(): %d/%d:%d. Odd ends: pad+heads+chain+tail: %d+%d+%d+%d.\n",
goodsbrk + sbrk_slack, sbrks, sbrk_good, sbrk_slack,
start_slack, total_chain, sbrked_remains);
+#endif /* DEBUGGING_MSTATS */
}
-#else
-void
-dump_mstats(char *s)
-{
-}
-#endif
#endif /* lint */
-
#ifdef USE_PERL_SBRK
-# if defined(__MACHTEN_PPC__) || defined(__NeXT__)
+# if defined(__MACHTEN_PPC__) || defined(NeXT) || defined(__NeXT__)
# define PERL_SBRK_VIA_MALLOC
/*
* MachTen's malloc() returns a buffer aligned on a two-byte boundary.
*
* 980701 Dominic Dunlop <domo@computer.org>
*/
-# define SYSTEM_ALLOC(a) ((void *)(((unsigned)malloc((a)+6)+6)&~7))
+# define SYSTEM_ALLOC_ALIGNMENT 2
# endif
# ifdef PERL_SBRK_VIA_MALLOC
-# if defined(HIDEMYMALLOC) || defined(EMBEDMYMALLOC)
-# 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
/* 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 */
# 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 */
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;