better messages from malloc()

Message-ID: <20001101233956.A520@monk.mps.ohio-state.edu>

p4raw-id: //depot/perl@7533

diff --git a/malloc.c b/malloc.c
index 7584000..fc37cb2 100644 (file)
--- a/malloc.c
+++ b/malloc.c
@@ -146,9 +146,15 @@
      # Fatal error reporting function
      croak(format, arg)                        warn(idem) + exit(1)
   
+     # Fatal error reporting function
+     croak2(format, arg1, arg2)                warn2(idem) + exit(1)
+  
      # Error reporting function
      warn(format, arg)                 fprintf(stderr, idem)
 
+     # Error reporting function
+     warn2(format, arg1, arg2)         fprintf(stderr, idem)
+
      # Locking/unlocking for MT operation
      MALLOC_LOCK                       MUTEX_LOCK(&PL_malloc_mutex)
      MALLOC_UNLOCK                     MUTEX_UNLOCK(&PL_malloc_mutex)
@@ -234,7 +240,12 @@
 #  include "perl.h"
 #  if defined(PERL_IMPLICIT_CONTEXT)
 #    define croak      Perl_croak_nocontext
+#    define croak2     Perl_croak_nocontext
 #    define warn       Perl_warn_nocontext
+#    define warn2      Perl_warn_nocontext
+#  else
+#    define croak2     croak
+#    define warn2      warn
 #  endif
 #else
 #  ifdef PERL_FOR_X2P
@@ -274,9 +285,15 @@
 #  ifndef croak                                /* make depend */
 #    define croak(mess, arg) (warn((mess), (arg)), exit(1))
 #  endif 
+#  ifndef croak2                       /* make depend */
+#    define croak2(mess, arg1, arg2) (warn2((mess), (arg1), (arg2)), exit(1))
+#  endif 
 #  ifndef warn
 #    define warn(mess, arg) fprintf(stderr, (mess), (arg))
 #  endif 
+#  ifndef warn
+#    define warn2(mess, arg1) fprintf(stderr, (mess), (arg1), (arg2))
+#  endif 
 #  ifdef DEBUG_m
 #    undef DEBUG_m
 #  endif 
@@ -851,18 +868,64 @@ static int        getpages_adjacent(MEM_SIZE require);
 #  define MUTEX_UNLOCK(m) STMT_START { if (*m) mutex_unlock(*m); } STMT_END
 #endif
 
+#ifndef BITS_IN_PTR
+#  define BITS_IN_PTR (8*PTRSIZE)
+#endif
+
+/*
+ * nextf[i] is the pointer to the next free block of size 2^i.  The
+ * smallest allocatable block is 8 bytes.  The overhead information
+ * precedes the data area returned to the user.
+ */
+#define        NBUCKETS (BITS_IN_PTR*BUCKETS_PER_POW2 + 1)
+static union overhead *nextf[NBUCKETS];
+
+#if defined(PURIFY) && !defined(USE_PERL_SBRK)
+#  define USE_PERL_SBRK
+#endif
+
+#ifdef USE_PERL_SBRK
+#define sbrk(a) Perl_sbrk(a)
+Malloc_t Perl_sbrk (int size);
+#else 
+#ifdef DONT_DECLARE_STD
+#ifdef I_UNISTD
+#include <unistd.h>
+#endif
+#else
+extern Malloc_t sbrk(int);
+#endif
+#endif
+
+#ifdef DEBUGGING_MSTATS
+/*
+ * nmalloc[i] is the difference between the number of mallocs and frees
+ * for a given block size.
+ */
+static u_int nmalloc[NBUCKETS];
+static  u_int sbrk_slack;
+static  u_int start_slack;
+#else  /* !( defined DEBUGGING_MSTATS ) */
+#  define sbrk_slack   0
+#endif
+
+static u_int goodsbrk;
+
 static char *emergency_buffer;
 static MEM_SIZE emergency_buffer_size;
+static int no_mem;     /* 0 if the last request for more memory succeeded.
+                          Otherwise the size of the failing request. */
 
 static Malloc_t
 emergency_sbrk(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: */
+    if (size >= BIG_SIZE && (!no_mem || (size < no_mem))) {
+       /* Give the possibility to recover, but avoid an infinite cycle. */
        MALLOC_UNLOCK;
-       croak("Out of memory during \"large\" request for %i bytes", size);
+       no_mem = size;
+       croak2("Out of memory during \"large\" request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack));
     }
 
     if (emergency_buffer_size >= rsize) {
@@ -910,7 +973,7 @@ emergency_sbrk(MEM_SIZE size)
     }
   do_croak:
     MALLOC_UNLOCK;
-    croak("Out of memory during request for %i bytes", size);
+    croak("Out of memory during request for %"UVuf" bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack));
     /* NOTREACHED */
     return Nullch;
 }
@@ -919,47 +982,6 @@ emergency_sbrk(MEM_SIZE size)
 #  define emergency_sbrk(size) -1
 #endif /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */
 
-#ifndef BITS_IN_PTR
-#  define BITS_IN_PTR (8*PTRSIZE)
-#endif
-
-/*
- * nextf[i] is the pointer to the next free block of size 2^i.  The
- * smallest allocatable block is 8 bytes.  The overhead information
- * precedes the data area returned to the user.
- */
-#define        NBUCKETS (BITS_IN_PTR*BUCKETS_PER_POW2 + 1)
-static union overhead *nextf[NBUCKETS];
-
-#if defined(PURIFY) && !defined(USE_PERL_SBRK)
-#  define USE_PERL_SBRK
-#endif
-
-#ifdef USE_PERL_SBRK
-#define sbrk(a) Perl_sbrk(a)
-Malloc_t Perl_sbrk (int size);
-#else 
-#ifdef DONT_DECLARE_STD
-#ifdef I_UNISTD
-#include <unistd.h>
-#endif
-#else
-extern Malloc_t sbrk(int);
-#endif
-#endif
-
-#ifdef DEBUGGING_MSTATS
-/*
- * nmalloc[i] is the difference between the number of mallocs and frees
- * for a given block size.
- */
-static u_int nmalloc[NBUCKETS];
-static  u_int sbrk_slack;
-static  u_int start_slack;
-#endif
-
-static u_int goodsbrk;
-
 #ifdef DEBUGGING
 #undef ASSERT
 #define        ASSERT(p,diag)   if (!(p)) botch(diag,STRINGIFY(p));  else
@@ -1035,7 +1057,28 @@ Perl_malloc(register size_t nbytes)
                {
                    dTHX;
                    if (!PL_nomemok) {
-                       PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
+                       char buff[80];
+                       char *eb = buff + sizeof(buff) - 1;
+                       char *s = eb;
+                       size_t n = nbytes;
+
+                       PerlIO_puts(PerlIO_stderr(),"Out of memory during request for ");
+#if defined(DEBUGGING) || defined(RCHECK)
+                       n = size;
+#endif
+                       *s = 0;                 
+                       do {
+                           *--s = '0' + (n % 10);
+                       } while (n /= 10);
+                       PerlIO_puts(PerlIO_stderr(),s);
+                       PerlIO_puts(PerlIO_stderr()," bytes, total sbrk() is ");
+                       s = eb;
+                       n = goodsbrk + sbrk_slack;
+                       do {
+                           *--s = '0' + (n % 10);
+                       } while (n /= 10);
+                       PerlIO_puts(PerlIO_stderr(),s);
+                       PerlIO_puts(PerlIO_stderr()," bytes!\n");
                        my_exit(1);
                    }
                }
@@ -1343,6 +1386,7 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket)
        sbrked_remains = require - needed;
        last_op = cp;
     }
+    no_mem = 0;
     last_sbrk_top = cp + require;
 #ifdef DEBUGGING_MSTATS
     goodsbrk += require;

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 1be2bc5..452938c 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2329,7 +2329,8 @@ The request was judged to be small, so the possibility to trap it
 depends on the way perl was compiled.  By default it is not trappable.
 However, if compiled for this, Perl may use the contents of C<$^M> as an
 emergency pool after die()ing with this message.  In this case the error
-is trappable I<once>.
+is trappable I<once>, and the error message will include the line and file
+where the failed request happened.
 
 =item Out of memory during ridiculously large request