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
# 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 */
#ifdef DEBUGGING
# undef DEBUG_m
-# define DEBUG_m(a) if (PL_debug & 128) a
+# define DEBUG_m(a) \
+ STMT_START { \
+ if (PERL_GET_INTERP) { dTHX; if (PL_debug & 128) { a; } } \
+ } STMT_END
#endif
/*
#define u_char unsigned char
#define u_int unsigned int
-
-#ifdef HAS_QUAD
-# define u_bigint UV /* Needs to eat *void. */
-#else /* needed? */
-# define u_bigint unsigned long /* Needs to eat *void. */
-#endif
-
+/*
+ * I removed the definition of u_bigint which appeared to be u_bigint = UV
+ * u_bigint was only used in TWOK_MASKED and TWOK_SHIFT
+ * where I have used PTR2UV. RMB
+ */
#define u_short unsigned short
/* 286 and atarist like big chunks, which gives too much overhead. */
# define MAX_PACKED (MAX_PACKED_POW2 * BUCKETS_PER_POW2 + BUCKET_POW2_SHIFT)
# define MAX_POW2_ALGO ((1<<(MAX_PACKED_POW2 + 1)) - M_OVERHEAD)
# define TWOK_MASK ((1<<LOG_OF_MIN_ARENA) - 1)
-# define TWOK_MASKED(x) ((u_bigint)(x) & ~TWOK_MASK)
-# define TWOK_SHIFT(x) ((u_bigint)(x) & TWOK_MASK)
-# define OV_INDEXp(block) ((u_char*)(TWOK_MASKED(block)))
+# define TWOK_MASKED(x) (PTR2UV(x) & ~TWOK_MASK)
+# define TWOK_SHIFT(x) (PTR2UV(x) & TWOK_MASK)
+# define OV_INDEXp(block) (INT2PTR(u_char*,TWOK_MASKED(block)))
# define OV_INDEX(block) (*OV_INDEXp(block))
# define OV_MAGIC(block,bucket) (*(OV_INDEXp(block) + \
(TWOK_SHIFT(block)>> \
static char *emergency_buffer;
static MEM_SIZE emergency_buffer_size;
-STATIC Malloc_t
-emergency_sbrk(pTHX_ 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)
{
MEM_SIZE rsize = (((size - 1)>>LOG_OF_MIN_ARENA) + 1)<<LOG_OF_MIN_ARENA;
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);
/* Got it, now detach SvPV: */
pv = SvPV(sv, n_a);
/* Check alignment: */
- if (((UV)(pv - sizeof(union overhead))) & (NEEDED_ALIGNMENT - 1)) {
+ if ((PTR2UV(pv) - sizeof(union overhead)) & (NEEDED_ALIGNMENT - 1)) {
PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n");
return (char *)-1; /* die die die */
}
#ifdef DEBUGGING
#undef ASSERT
#define ASSERT(p,diag) if (!(p)) botch(diag,STRINGIFY(p)); else
-STATIC void
-botch(pTHX_ char *diag, char *s)
+static void
+botch(char *diag, char *s)
{
PerlIO_printf(PerlIO_stderr(), "assertion botched (%s?): %s\n", diag, s);
PerlProc_abort();
BARK_64K_LIMIT("Allocation",nbytes,nbytes);
#ifdef DEBUGGING
if ((long)nbytes < 0)
- croak("%s", "panic: malloc");
+ croak("%s", "panic: malloc");
#endif
MALLOC_LOCK;
if ((p = nextf[bucket]) == NULL) {
MALLOC_UNLOCK;
#ifdef PERL_CORE
- if (!PL_nomemok) {
- PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
- my_exit(1);
+ {
+ dTHX;
+ if (!PL_nomemok) {
+ PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
+ my_exit(1);
+ }
}
#else
return (NULL);
/* remove from linked list */
#if defined(RCHECK)
- if (((UV)p) & (MEM_ALIGNBYTES - 1))
+ if ((PTR2UV(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
static char max_bucket;
/* Cutoff a piece of one of the chunks in the chain. Prefer smaller chunk. */
-STATIC void *
-get_from_chain(pTHX_ MEM_SIZE size)
+static void *
+get_from_chain(MEM_SIZE size)
{
struct chunk_chain_s *elt = chunk_chain, **oldp = &chunk_chain;
struct chunk_chain_s **oldgoodp = NULL;
}
}
-STATIC void
-add_to_chain(pTHX_ void *p, MEM_SIZE size, MEM_SIZE chip)
+static void
+add_to_chain(void *p, MEM_SIZE size, MEM_SIZE chip)
{
struct chunk_chain_s *next = chunk_chain;
char *cp = (char*)p;
n_chunks++;
}
-STATIC void *
-get_from_bigger_buckets(pTHX_ int bucket, MEM_SIZE size)
+static void *
+get_from_bigger_buckets(int bucket, MEM_SIZE size)
{
int price = 1;
static int bucketprice[NBUCKETS];
return NULL;
}
-STATIC union overhead *
-getpages(pTHX_ int needed, int *nblksp, int bucket)
+static union overhead *
+getpages(int needed, int *nblksp, int bucket)
{
/* Need to do (possibly expensive) system call. Try to
optimize it for rare calling. */
# 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));
+ if (PTR2UV(cp) & (WANTED_ALIGNMENT - 1)) { /* Not aligned. */
+ slack = WANTED_ALIGNMENT - (PTR2UV(cp) & (WANTED_ALIGNMENT - 1));
add += slack;
}
# endif
*/
# if NEEDED_ALIGNMENT > MEM_ALIGNBYTES
- if ((UV)ovp & (NEEDED_ALIGNMENT - 1))
+ if (PTR2UV(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)) {
+ if (PTR2UV(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) &
+ (int)(PTR2UV(ovp) & (MEM_ALIGNBYTES - 1))));
+ ovp = INT2PTR(union overhead *,(PTR2UV(ovp) + MEM_ALIGNBYTES) &
(MEM_ALIGNBYTES - 1));
(*nblksp)--;
# if defined(DEBUGGING_MSTATS)
return ovp;
}
-STATIC int
-getpages_adjacent(pTHX_ int require)
+static int
+getpages_adjacent(int require)
{
if (require <= sbrked_remains) {
sbrked_remains -= require;
/*
* Allocate more memory to the indicated bucket.
*/
-STATIC void
-morecore(pTHX_ register int bucket)
+static void
+morecore(register int bucket)
{
register union overhead *ovp;
register int rnu; /* 2^rnu bytes will be requested */
Free_t
Perl_mfree(void *mp)
-{
+{
register MEM_SIZE size;
register union overhead *ovp;
char *cp = (char*)mp;
Malloc_t
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);
}
MEM_SIZE
-Perl_malloced_size(pTHX_ void *p)
+Perl_malloced_size(void *p)
{
union overhead *ovp = (union overhead *)
((caddr_t)p - sizeof (union overhead) * CHUNK_SHIFT);