X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=malloc.c;h=6f8f548f1efd60e88783847696688829d04b9d01;hb=94d4f21ce5099f301ed168bfe5ebf5e185d03459;hp=b4be0316d2bfb8a9bea16f7123b3e1db4cadf29b;hpb=ba1485b3aac941801125075387ba52c091447aa2;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/malloc.c b/malloc.c
index b4be031..6f8f548 100644
--- a/malloc.c
+++ b/malloc.c
@@ -2,10 +2,14 @@
  *
  */
 
+#if defined(PERL_CORE) && !defined(DEBUGGING_MSTATS)
+#  define DEBUGGING_MSTATS
+#endif 
+
 #ifndef lint
-#ifdef DEBUGGING
-#define RCHECK
-#endif
+#  if defined(DEBUGGING) && !defined(NO_RCHECK)
+#    define RCHECK
+#  endif
 /*
  * malloc.c (Caltech) 2/21/82
  * Chris Kingsley, kingsley@cit-20.
@@ -174,7 +178,7 @@ static u_short blk_shift[11 - 3] = {256, 128, 64, 32,
 static char *emergency_buffer;
 static MEM_SIZE emergency_buffer_size;
 
-static char *
+static Malloc_t
 emergency_sbrk(size)
     MEM_SIZE size;
 {
@@ -185,6 +189,7 @@ emergency_sbrk(size)
     }
 
     if (!emergency_buffer) {		
+	dTHR;
 	/* First offense, give a possibility to recover by dieing. */
 	/* No malloc involved here: */
 	GV **gvp = (GV**)hv_fetch(defstash, "^M", 2, 0);
@@ -232,9 +237,15 @@ static	union overhead *nextf[NBUCKETS];
 
 #ifdef USE_PERL_SBRK
 #define sbrk(a) Perl_sbrk(a)
-char *  Perl_sbrk _((int size));
+Malloc_t Perl_sbrk _((int size));
+#else 
+#ifdef DONT_DECLARE_STD
+#ifdef I_UNISTD
+#include <unistd.h>
+#endif
 #else
-extern	char *sbrk();
+extern	Malloc_t sbrk(int);
+#endif
 #endif
 
 #ifdef DEBUGGING_MSTATS
@@ -251,19 +262,17 @@ static  u_int start_slack;
 #ifdef DEBUGGING
 #define	ASSERT(p)   if (!(p)) botch(STRINGIFY(p));  else
 static void
-botch(s)
-	char *s;
+botch(char *s)
 {
 	PerlIO_printf(PerlIO_stderr(), "assertion botched: %s\n", s);
-	abort();
+	PerlProc_abort();
 }
 #else
 #define	ASSERT(p)
 #endif
 
 Malloc_t
-malloc(nbytes)
-	register MEM_SIZE nbytes;
+malloc(register size_t nbytes)
 {
   	register union overhead *p;
   	register int bucket = 0;
@@ -287,6 +296,7 @@ malloc(nbytes)
 #endif
 #endif /* PERL_CORE */
 
+	MUTEX_LOCK(&malloc_mutex);
 	/*
 	 * Convert amount of memory requested into
 	 * closest block size stored in hash buckets
@@ -317,6 +327,7 @@ malloc(nbytes)
   	if (nextf[bucket] == NULL)    
   		morecore(bucket);
   	if ((p = (union overhead *)nextf[bucket]) == NULL) {
+		MUTEX_UNLOCK(&malloc_mutex);
 #ifdef PERL_CORE
 		if (!nomemok) {
 		    PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
@@ -328,8 +339,8 @@ malloc(nbytes)
 	}
 
 #ifdef PERL_CORE
-    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",
-	(unsigned long)(p+1),an++,(long)size));
+    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05lu) malloc %ld bytes\n",
+	(unsigned long)(p+1),(unsigned long)(an++),(long)size));
 #endif /* PERL_CORE */
 
 	/* remove from linked list */
@@ -354,6 +365,7 @@ malloc(nbytes)
 	p->ov_rmagic = RMAGIC;
   	*((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
 #endif
+	MUTEX_UNLOCK(&malloc_mutex);
   	return ((Malloc_t)(p + CHUNK_SHIFT));
 }
 
@@ -361,10 +373,9 @@ malloc(nbytes)
  * Allocate more memory to the indicated bucket.
  */
 static void
-morecore(bucket)
-	register int bucket;
+morecore(register int bucket)
 {
-  	register union overhead *op;
+  	register union overhead *ovp;
   	register int rnu;       /* 2^rnu bytes will be requested */
   	register int nblks;     /* become nblks blocks of the desired size */
 	register MEM_SIZE siz, needed;
@@ -381,18 +392,15 @@ morecore(bucket)
 	 * make getpageize call?
 	 */
 #ifndef atarist /* on the atari we dont have to worry about this */
-  	op = (union overhead *)sbrk(0);
+  	ovp = (union overhead *)sbrk(0);
 #  ifndef I286
-#    ifdef PACK_MALLOC
-  	if ((u_int)op & 0x7ff)
-  		(void)sbrk(slack = 2048 - ((u_int)op & 0x7ff));
-#    else
-  	if ((u_int)op & 0x3ff)
-  		(void)sbrk(slack = 1024 - ((u_int)op & 0x3ff));
-#    endif
+  	if ((UV)ovp & (0x7FF >> CHUNK_SHIFT)) {
+	    slack = (0x800 >> CHUNK_SHIFT) - ((UV)ovp & (0x7FF >> CHUNK_SHIFT));
+	    (void)sbrk(slack);
 #    if defined(DEBUGGING_MSTATS)
-	sbrk_slack += slack;
+	    sbrk_slack += slack;
 #    endif
+	}
 #  else
 	/* The sbrk(0) call on the I286 always returns the next segment */
 #  endif
@@ -411,11 +419,11 @@ morecore(bucket)
 #ifdef TWO_POT_OPTIMIZE
 	needed += (bucket >= (FIRST_BIG_TWO_POT - 3) ? PERL_PAGESIZE : 0);
 #endif 
-	op = (union overhead *)sbrk(needed);
+	ovp = (union overhead *)sbrk(needed);
 	/* no more room! */
-  	if (op == (union overhead *)-1) {
-	    op = (union overhead *)emergency_sbrk(needed);
-	    if (op == (union overhead *)-1)
+  	if (ovp == (union overhead *)-1) {
+	    ovp = (union overhead *)emergency_sbrk(needed);
+	    if (ovp == (union overhead *)-1)
   		return;
 	}
 #ifdef DEBUGGING_MSTATS
@@ -427,11 +435,11 @@ morecore(bucket)
 	 */
 #ifndef I286
 #  ifdef PACK_MALLOC
-	if ((u_int)op & 0x7ff)
+	if ((UV)ovp & 0x7FF)
 		croak("panic: Off-page sbrk");
 #  endif
-  	if ((u_int)op & 7) {
-  		op = (union overhead *)(((MEM_SIZE)op + 8) &~ 7);
+  	if ((UV)ovp & 7) {
+  		ovp = (union overhead *)(((UV)ovp + 8) & ~7);
   		nblks--;
   	}
 #else
@@ -443,29 +451,29 @@ morecore(bucket)
 	 */
   	siz = 1 << (bucket + 3);
 #ifdef PACK_MALLOC
-	*(u_char*)op = bucket;	/* Fill index. */
+	*(u_char*)ovp = bucket;	/* Fill index. */
 	if (bucket <= MAX_PACKED - 3) {
-	    op = (union overhead *) ((char*)op + blk_shift[bucket]);
+	    ovp = (union overhead *) ((char*)ovp + blk_shift[bucket]);
 	    nblks = n_blks[bucket];
 #  ifdef DEBUGGING_MSTATS
 	    start_slack += blk_shift[bucket];
 #  endif
 	} else if (bucket <= 11 - 1 - 3) {
-	    op = (union overhead *) ((char*)op + blk_shift[bucket]);
+	    ovp = (union overhead *) ((char*)ovp + blk_shift[bucket]);
 	    /* nblks = n_blks[bucket]; */
 	    siz -= sizeof(union overhead);
-	} else op++;		/* One chunk per block. */
+	} else ovp++;		/* One chunk per block. */
 #endif /* !PACK_MALLOC */
-  	nextf[bucket] = op;
+  	nextf[bucket] = ovp;
 #ifdef DEBUGGING_MSTATS
 	nmalloc[bucket] += nblks;
 #endif 
   	while (--nblks > 0) {
-		op->ov_next = (union overhead *)((caddr_t)op + siz);
-		op = (union overhead *)((caddr_t)op + siz);
+		ovp->ov_next = (union overhead *)((caddr_t)ovp + siz);
+		ovp = (union overhead *)((caddr_t)ovp + siz);
   	}
 	/* Not all sbrks return zeroed memory.*/
-	op->ov_next = (union overhead *)NULL;
+	ovp->ov_next = (union overhead *)NULL;
 #ifdef PACK_MALLOC
 	if (bucket == 7 - 3) {	/* Special case, explanation is above. */
 	    union overhead *n_op = nextf[7 - 3]->ov_next;
@@ -477,53 +485,54 @@ morecore(bucket)
 }
 
 Free_t
-free(mp)
-	Malloc_t mp;
+free(void *mp)
 {   
   	register MEM_SIZE size;
-	register union overhead *op;
+	register union overhead *ovp;
 	char *cp = (char*)mp;
 #ifdef PACK_MALLOC
 	u_char bucket;
 #endif 
 
 #ifdef PERL_CORE
-    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(unsigned long)cp,an++));
+    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05lu) free\n",(unsigned long)cp,(unsigned long)(an++)));
 #endif /* PERL_CORE */
 
 	if (cp == NULL)
 		return;
-	op = (union overhead *)((caddr_t)cp 
-				- sizeof (union overhead) * CHUNK_SHIFT);
+	ovp = (union overhead *)((caddr_t)cp 
+				 - sizeof (union overhead) * CHUNK_SHIFT);
 #ifdef PACK_MALLOC
-	bucket = OV_INDEX(op);
+	bucket = OV_INDEX(ovp);
 #endif 
-	if (OV_MAGIC(op, bucket) != MAGIC) {
-		static bad_free_warn = -1;
+	if (OV_MAGIC(ovp, bucket) != MAGIC) {
+		static int bad_free_warn = -1;
 		if (bad_free_warn == -1) {
-		    char *pbf = getenv("PERL_BADFREE");
+		    char *pbf = PerlEnv_getenv("PERL_BADFREE");
 		    bad_free_warn = (pbf) ? atoi(pbf) : 1;
 		}
 		if (!bad_free_warn)
 		    return;
 #ifdef RCHECK
 		warn("%s free() ignored",
-		    op->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
+		    ovp->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
 #else
 		warn("Bad free() ignored");
 #endif
 		return;				/* sanity */
 	}
+	MUTEX_LOCK(&malloc_mutex);
 #ifdef RCHECK
-  	ASSERT(op->ov_rmagic == RMAGIC);
-	if (OV_INDEX(op) <= MAX_SHORT_BUCKET)
-		ASSERT(*(u_int *)((caddr_t)op + op->ov_size + 1 - RSLOP) == RMAGIC);
-	op->ov_rmagic = RMAGIC - 1;
-#endif
-  	ASSERT(OV_INDEX(op) < NBUCKETS);
-  	size = OV_INDEX(op);
-	op->ov_next = nextf[size];
-  	nextf[size] = op;
+  	ASSERT(ovp->ov_rmagic == RMAGIC);
+	if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET)
+		ASSERT(*(u_int *)((caddr_t)ovp + ovp->ov_size + 1 - RSLOP) == RMAGIC);
+	ovp->ov_rmagic = RMAGIC - 1;
+#endif
+  	ASSERT(OV_INDEX(ovp) < NBUCKETS);
+  	size = OV_INDEX(ovp);
+	ovp->ov_next = nextf[size];
+  	nextf[size] = ovp;
+	MUTEX_UNLOCK(&malloc_mutex);
 }
 
 /*
@@ -540,12 +549,10 @@ free(mp)
 int reall_srchlen = 4;	/* 4 should be plenty, -1 =>'s whole list */
 
 Malloc_t
-realloc(mp, nbytes)
-	Malloc_t mp; 
-	MEM_SIZE nbytes;
+realloc(void *mp, size_t nbytes)
 {   
   	register MEM_SIZE onb;
-	union overhead *op;
+	union overhead *ovp;
   	char *res;
 	register int i;
 	int was_alloced = 0;
@@ -571,10 +578,11 @@ realloc(mp, nbytes)
 #endif
 #endif /* PERL_CORE */
 
-	op = (union overhead *)((caddr_t)cp 
-				- sizeof (union overhead) * CHUNK_SHIFT);
-	i = OV_INDEX(op);
-	if (OV_MAGIC(op, i) == MAGIC) {
+	MUTEX_LOCK(&malloc_mutex);
+	ovp = (union overhead *)((caddr_t)cp 
+				 - sizeof (union overhead) * CHUNK_SHIFT);
+	i = OV_INDEX(ovp);
+	if (OV_MAGIC(ovp, i) == MAGIC) {
 		was_alloced = 1;
 	} else {
 		/*
@@ -588,8 +596,8 @@ realloc(mp, nbytes)
 		 * the memory block being realloc'd is the
 		 * smallest possible.
 		 */
-		if ((i = findbucket(op, 1)) < 0 &&
-		    (i = findbucket(op, reall_srchlen)) < 0)
+		if ((i = findbucket(ovp, 1)) < 0 &&
+		    (i = findbucket(ovp, reall_srchlen)) < 0)
 			i = 0;
 	}
 	onb = (1L << (i + 3)) - 
@@ -621,7 +629,7 @@ realloc(mp, nbytes)
 		 * Record new allocated size of block and
 		 * bound space with magic numbers.
 		 */
-		if (OV_INDEX(op) <= MAX_SHORT_BUCKET) {
+		if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) {
 			/*
 			 * Convert amount of memory requested into
 			 * closest block size stored in hash buckets
@@ -630,13 +638,15 @@ realloc(mp, nbytes)
 			 */
 			nbytes += M_OVERHEAD;
 			nbytes = (nbytes + 3) &~ 3; 
-			op->ov_size = nbytes - 1;
-			*((u_int *)((caddr_t)op + nbytes - RSLOP)) = RMAGIC;
+			ovp->ov_size = nbytes - 1;
+			*((u_int *)((caddr_t)ovp + nbytes - RSLOP)) = RMAGIC;
 		}
 #endif
 		res = cp;
+		MUTEX_UNLOCK(&malloc_mutex);
 	}
 	else {
+		MUTEX_UNLOCK(&malloc_mutex);
 		if ((res = (char*)malloc(nbytes)) == NULL)
 			return (NULL);
 		if (cp != res)			/* common optimization */
@@ -648,9 +658,9 @@ realloc(mp, nbytes)
 #ifdef PERL_CORE
 #ifdef DEBUGGING
     if (debug & 128) {
-	PerlIO_printf(PerlIO_stderr(), "0x%lx: (%05d) rfree\n",(unsigned long)res,an++);
-	PerlIO_printf(PerlIO_stderr(), "0x%lx: (%05d) realloc %ld bytes\n",
-	    (unsigned long)res,an++,(long)size);
+	PerlIO_printf(Perl_debug_log, "0x%lx: (%05lu) rfree\n",(unsigned long)res,(unsigned long)(an++));
+	PerlIO_printf(Perl_debug_log, "0x%lx: (%05lu) realloc %ld bytes\n",
+	    (unsigned long)res,(unsigned long)(an++),(long)size);
     }
 #endif
 #endif /* PERL_CORE */
@@ -663,9 +673,7 @@ realloc(mp, nbytes)
  * Return bucket number, or -1 if not found.
  */
 static int
-findbucket(freep, srchlen)
-	union overhead *freep;
-	int srchlen;
+findbucket(union overhead *freep, int srchlen)
 {
 	register union overhead *p;
 	register int i, j;
@@ -682,9 +690,7 @@ findbucket(freep, srchlen)
 }
 
 Malloc_t
-calloc(elements, size)
-	register MEM_SIZE elements;
-	register MEM_SIZE size;
+calloc(register size_t elements, register size_t size)
 {
     long sz = elements * size;
     Malloc_t p = malloc(sz);
@@ -704,8 +710,7 @@ calloc(elements, size)
  * frees for each size category.
  */
 void
-dump_mstats(s)
-	char *s;
+dump_mstats(char *s)
 {
   	register int i, j;
   	register union overhead *p;
@@ -737,8 +742,7 @@ dump_mstats(s)
 }
 #else
 void
-dump_mstats(s)
-    char *s;
+dump_mstats(char *s)
 {
 }
 #endif
@@ -773,7 +777,7 @@ static long Perl_sbrk_oldsize;
 #   define PERLSBRK_32_K (1<<15)
 #   define PERLSBRK_64_K (1<<16)
 
-char *
+Malloc_t
 Perl_sbrk(size)
 int size;
 {
@@ -784,6 +788,9 @@ int size;
 #ifdef PERL_CORE
     reqsize = size; /* just for the DEBUG_m statement */
 #endif
+#ifdef PACK_MALLOC
+    size = (size + 0x7ff) & ~0x7ff;
+#endif
     if (size <= Perl_sbrk_oldsize) {
 	got = Perl_sbrk_oldchunk;
 	Perl_sbrk_oldchunk += size;
@@ -799,6 +806,9 @@ int size;
 	small = 1;
       }
       got = (IV)SYSTEM_ALLOC(size);
+#ifdef PACK_MALLOC
+      got = (got + 0x7ff) & ~0x7ff;
+#endif
       if (small) {
 	/* Chunk is small, register the rest for future allocs. */
 	Perl_sbrk_oldchunk = got + reqsize;
@@ -807,7 +817,7 @@ int size;
     }
 
 #ifdef PERL_CORE
-    DEBUG_m(PerlIO_printf(PerlIO_stderr(), "sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%lx\n",
+    DEBUG_m(PerlIO_printf(Perl_debug_log, "sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%lx\n",
 		    size, reqsize, Perl_sbrk_oldsize, got));
 #endif