malloc.c tweaks

	Message-Id: <199808012246.SAA00699@monk.mps.ohio-state.edu>
	Subject: [PATCH 5.005_*] Better malloc.c

p4raw-id: //depot/maint-5.005/perl@1707

1 files changed, 40 insertions, 15 deletions

diff --git a/malloc.c b/malloc.c
index f46c0c05dd..bba7741351 100644
--- a/malloc.c
+++ b/malloc.c
@@ -101,6 +101,11 @@
     # This many continuous sbrk()s compensate for one discontinuous one.
     SBRK_FAILURE_PRICE		50
 
+    # Some configurations may ask for 12-byte-or-so allocations which
+    # require 8-byte alignment (?!).  In such situation one needs to
+    # define this to disable 12-byte bucket (will increase memory footprint)
+    STRICT_ALIGNMENT		undef
+
   This implementation assumes that calling PerlIO_printf() does not
   result in any memory allocation calls (used during a panic).
 
@@ -281,6 +286,7 @@ 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 */
@@ -571,46 +577,59 @@ static Malloc_t
 emergency_sbrk(size)
     MEM_SIZE size;
 {
+    MEM_SIZE rsize = (((size - 1)>>LOG_OF_MIN_ARENA) + 1)<<LOG_OF_MIN_ARENA;
+
     if (size >= BIG_SIZE) {
 	/* Give the possibility to recover: */
 	MUTEX_UNLOCK(&PL_malloc_mutex);
 	croak("Out of memory during \"large\" request for %i bytes", size);
     }
 
-    if (!emergency_buffer) {		
+    if (emergency_buffer_size >= rsize) {
+	char *old = emergency_buffer;
+	
+	emergency_buffer_size -= rsize;
+	emergency_buffer += rsize;
+	return old;
+    } else {		
 	dTHR;
 	/* 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;
 
+	if (emergency_buffer_size) {
+	    add_to_chain(emergency_buffer, emergency_buffer_size, 0);
+	    emergency_buffer_size = 0;
+	    emergency_buffer = Nullch;
+	    have = 1;
+	}
 	if (!gvp) gvp = (GV**)hv_fetch(PL_defstash, "\015", 1, 0);
 	if (!gvp || !(sv = GvSV(*gvp)) || !SvPOK(sv) 
-	    || (SvLEN(sv) < (1<<LOG_OF_MIN_ARENA) - M_OVERHEAD)) 
+	    || (SvLEN(sv) < (1<<LOG_OF_MIN_ARENA) - M_OVERHEAD)) {
+	    if (have)
+		goto do_croak;
 	    return (char *)-1;		/* Now die die die... */
-
+	}
 	/* Got it, now detach SvPV: */
 	pv = SvPV(sv, PL_na);
 	/* Check alignment: */
-	if (((u_bigint)(pv - M_OVERHEAD)) & ((1<<LOG_OF_MIN_ARENA) - 1)) {
+	if (((UV)(pv - sizeof(union overhead))) & ((1<<LOG_OF_MIN_ARENA) - 1)) {
 	    PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n");
 	    return (char *)-1;		/* die die die */
 	}
 
-	emergency_buffer = pv - M_OVERHEAD;
-	emergency_buffer_size = SvLEN(sv) + M_OVERHEAD;
+	emergency_buffer = pv - sizeof(union overhead);
+	emergency_buffer_size = malloced_size(pv) + M_OVERHEAD;
 	SvPOK_off(sv);
-	SvREADONLY_on(sv);
-	MUTEX_UNLOCK(&PL_malloc_mutex);
-	croak("Out of memory during request for %i bytes", size);
-    }
-    else if (emergency_buffer_size >= size) {
-	emergency_buffer_size -= size;
-	return emergency_buffer + emergency_buffer_size;
+	SvPVX(sv) = Nullch;
+	SvCUR(sv) = SvLEN(sv) = 0;
     }
-    
-    return (char *)-1;			/* poor guy... */
+  do_croak:
+    MUTEX_UNLOCK(&PL_malloc_mutex);
+    croak("Out of memory during request for %i bytes", size);
 }
 
 #else /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */
@@ -1033,6 +1052,12 @@ getpages_adjacent(int require)
 	    sbrked_remains = 0;
 	    last_sbrk_top = cp + require;
 	} else {
+	    if (cp == (char*)-1) {	/* Out of memory */
+#ifdef DEBUGGING_MSTATS
+		goodsbrk -= require;
+#endif
+		return 0;
+	    }
 	    /* Report the failure: */
 	    if (sbrked_remains)
 		add_to_chain((void*)(last_sbrk_top - sbrked_remains),