Cosmetic malloc patch

	Message-Id: <199811100003.TAA05815@monk.mps.ohio-state.edu>

p4raw-id: //depot/perl@2320

1 files changed, 73 insertions, 16 deletions

diff --git a/malloc.c b/malloc.c
index 79122fdd26..2006e3f4d0 100644
--- a/malloc.c
+++ b/malloc.c
@@ -3,7 +3,8 @@
  */
 
 /*
-  Here are some notes on configuring Perl's malloc.
+  Here are some notes on configuring Perl's malloc.  (For non-perl
+  usage see below.)
  
   There are two macros which serve as bulk disablers of advanced
   features of this malloc: NO_FANCY_MALLOC, PLAIN_MALLOC (undef by
@@ -111,6 +112,43 @@
 
  */
 
+/*
+   If used outside of Perl environment, it may be useful to redefine
+   the following macros (listed below with defaults):
+
+     # Type of address returned by allocation functions
+     Malloc_t				void *
+
+     # Type of size argument for allocation functions
+     MEM_SIZE				unsigned long
+
+     # Maximal value in LONG
+     LONG_MAX				0x7FFFFFFF
+
+     # Unsigned integer type big enough to keep a pointer
+     UV					unsigned long
+
+     # Type of pointer with 1-byte granularity
+     caddr_t				char *
+
+     # Type returned by free()
+     Free_t				void
+
+     # Fatal error reporting function
+     croak(format, arg)			warn(idem) + exit(1)
+  
+     # Error reporting function
+     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)
+
+     # Locking/unlocking mutex for MT operation
+     MUTEX_LOCK(l)			void
+     MUTEX_UNLOCK(l)			void
+ */
+
 #ifndef NO_FANCY_MALLOC
 #  ifndef SMALL_BUCKET_VIA_TABLE
 #    define SMALL_BUCKET_VIA_TABLE
@@ -167,7 +205,18 @@
  * implementation, the available sizes are 2^n-4 (or 2^n-12) bytes long.
  * If PACK_MALLOC is defined, small blocks are 2^n bytes long.
  * This is designed for use in a program that uses vast quantities of memory,
- * but bombs when it runs out. 
+ * but bombs when it runs out.
+ * 
+ * Modifications Copyright Ilya Zakharevich 1996-98.
+ * 
+ * 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.)
+ *
+ * Allocations of small blocks are now table-driven to many different
+ * buckets.  Sizes of really big buckets are increased to accomodata
+ * common size=power-of-2 blocks.  Running-out-of-memory is made into
+ * an exception.  Deeply configurable and thread-safe.
+ * 
  */
 
 #ifdef PERL_CORE
@@ -206,10 +255,10 @@
 #    define PerlIO_stderr() stderr
 #  endif
 #  ifndef croak				/* make depend */
-#    define croak(mess, arg) warn((mess), (arg)); exit(1);
+#    define croak(mess, arg) (warn((mess), (arg)), exit(1))
 #  endif 
 #  ifndef warn
-#    define warn(mess, arg) fprintf(stderr, (mess), (arg));
+#    define warn(mess, arg) fprintf(stderr, (mess), (arg))
 #  endif 
 #  ifdef DEBUG_m
 #    undef DEBUG_m
@@ -228,6 +277,14 @@
 #  define MUTEX_UNLOCK(l)
 #endif 
 
+#ifndef MALLOC_LOCK
+#  define MALLOC_LOCK		MUTEX_LOCK(PL_malloc_mutex)
+#endif 
+
+#ifndef MALLOC_UNLOCK
+#  define MALLOC_UNLOCK		MUTEX_UNLOCK(PL_malloc_mutex)
+#endif 
+
 #ifdef DEBUGGING
 #  undef DEBUG_m
 #  define DEBUG_m(a)  if (PL_debug & 128)   a
@@ -588,7 +645,7 @@ emergency_sbrk(MEM_SIZE size)
 
     if (size >= BIG_SIZE) {
 	/* Give the possibility to recover: */
-	MUTEX_UNLOCK(&PL_malloc_mutex);
+	MALLOC_UNLOCK;
 	croak("Out of memory during \"large\" request for %i bytes", size);
     }
 
@@ -635,7 +692,7 @@ emergency_sbrk(MEM_SIZE size)
 	SvCUR(sv) = SvLEN(sv) = 0;
     }
   do_croak:
-    MUTEX_UNLOCK(&PL_malloc_mutex);
+    MALLOC_UNLOCK;
     croak("Out of memory during request for %i bytes", size);
 }
 
@@ -706,7 +763,7 @@ malloc(register size_t nbytes)
 		croak("%s", "panic: malloc");
 #endif
 
-	MUTEX_LOCK(&PL_malloc_mutex);
+	MALLOC_LOCK;
 	/*
 	 * Convert amount of memory requested into
 	 * closest block size stored in hash buckets
@@ -745,7 +802,7 @@ malloc(register size_t nbytes)
   	if (nextf[bucket] == NULL)    
   		morecore(bucket);
   	if ((p = nextf[bucket]) == NULL) {
-		MUTEX_UNLOCK(&PL_malloc_mutex);
+		MALLOC_UNLOCK;
 #ifdef PERL_CORE
 		if (!PL_nomemok) {
 		    PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
@@ -795,7 +852,7 @@ malloc(register size_t nbytes)
 	    *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
 	}
 #endif
-	MUTEX_UNLOCK(&PL_malloc_mutex);
+	MALLOC_UNLOCK;
   	return ((Malloc_t)(p + CHUNK_SHIFT));
 }
 
@@ -980,7 +1037,7 @@ getpages(int needed, int *nblksp, int bucket)
 				      "failed to fix bad sbrk()\n"));
 #ifdef PACK_MALLOC
 		if (slack) {
-		    MUTEX_UNLOCK(&PL_malloc_mutex);
+		    MALLOC_UNLOCK;
 		    croak("%s", "panic: Off-page sbrk");
 		}
 #endif
@@ -1096,7 +1153,7 @@ morecore(register int bucket)
   	if (nextf[bucket])
   		return;
 	if (bucket == sizeof(MEM_SIZE)*8*BUCKETS_PER_POW2) {
-	    MUTEX_UNLOCK(&PL_malloc_mutex);
+	    MALLOC_UNLOCK;
 	    croak("%s", "Out of memory during ridiculously large request");
 	}
 	if (bucket > max_bucket)
@@ -1225,7 +1282,7 @@ free(void *mp)
 #endif
 		return;				/* sanity */
 	    }
-	MUTEX_LOCK(&PL_malloc_mutex);
+	MALLOC_LOCK;
 #ifdef RCHECK
   	ASSERT(ovp->ov_rmagic == RMAGIC, "chunk's head overwrite");
 	if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) {
@@ -1248,7 +1305,7 @@ free(void *mp)
   	size = OV_INDEX(ovp);
 	ovp->ov_next = nextf[size];
   	nextf[size] = ovp;
-	MUTEX_UNLOCK(&PL_malloc_mutex);
+	MALLOC_UNLOCK;
 }
 
 /*
@@ -1286,7 +1343,7 @@ realloc(void *mp, size_t nbytes)
 	if (!cp)
 		return malloc(nbytes);
 
-	MUTEX_LOCK(&PL_malloc_mutex);
+	MALLOC_LOCK;
 	ovp = (union overhead *)((caddr_t)cp 
 				- sizeof (union overhead) * CHUNK_SHIFT);
 	bucket = OV_INDEX(ovp);
@@ -1384,7 +1441,7 @@ realloc(void *mp, size_t nbytes)
 		}
 #endif
 		res = cp;
-		MUTEX_UNLOCK(&PL_malloc_mutex);
+		MALLOC_UNLOCK;
 		DEBUG_m(PerlIO_printf(Perl_debug_log, 
 			      "0x%lx: (%05lu) realloc %ld bytes inplace\n",
 			      (unsigned long)res,(unsigned long)(PL_an++),
@@ -1416,7 +1473,7 @@ realloc(void *mp, size_t nbytes)
 		goto hard_way;
 	} else {
 	  hard_way:
-	    MUTEX_UNLOCK(&PL_malloc_mutex);
+	    MALLOC_UNLOCK;
 	    DEBUG_m(PerlIO_printf(Perl_debug_log, 
 			      "0x%lx: (%05lu) realloc %ld bytes the hard way\n",
 			      (unsigned long)cp,(unsigned long)(PL_an++),