make generic "Out of memory!" error more specific

The problem: When perl runs out of memory, it outputs a generic "Out of
memory!" error and exits. This makes it hard to track down what's
happening in a complex system, especially since the message does not
even mention perl.

This patch contains two main changes:

1. vec() in lvalue context can throw fake "Out of memory!" errors when
   it discovers that the index being assigned to is too big. Unlike real
   allocation errors, these are trappable with try {}/eval {}.

   This message has been changed to "Out of memory during vec in lvalue
   context" (and since it comes from a Perl_croak() call, it will
   generally have a script name and line number attached).

2. All other places in the source code that can emit "Out of memory!"
   errors have been changed to attach a location identifier to the
   message. For example: "Out of memory in perl:util:safesysmalloc"

   This way the error message at least mentions "perl".

Fixes #21672.

doop.c

@@ -908,7 +908,7 @@ Perl_do_vecset(pTHX_ SV *sv)
         assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE)));
         if (errflags & LVf_NEG_OFF)
             Perl_croak_nocontext("Negative offset to vec in lvalue context");
-        Perl_croak_nocontext("Out of memory!");
+        Perl_croak_nocontext("Out of memory during vec in lvalue context");
     }
 
     if (!targ)
@@ -938,7 +938,7 @@ Perl_do_vecset(pTHX_ SV *sv)
     else if (size > 8) {
         int n = size/8;
         if (offset > Size_t_MAX / n - 1) /* would overflow */
-            Perl_croak_nocontext("Out of memory!");
+            Perl_croak_nocontext("Out of memory during vec in lvalue context");
         offset *= n;
     }
 

embed.fnc

@@ -855,6 +855,9 @@ Tfprv	|void	|croak_caller	|NULLOK const char *pat 		\
 				|...
 CTrs	|void	|croak_memory_wrap
 Tpr	|void	|croak_no_mem
+Tpr	|void	|croak_no_mem_ext					\
+				|NN const char *context 		\
+				|STRLEN len
 ATdpr	|void	|croak_no_modify
 TXpr	|void	|croak_popstack
 Adpr	|void	|croak_sv	|NN SV *baseex

embed.h

@@ -921,6 +921,7 @@
 #   define create_eval_scope(a,b,c)             Perl_create_eval_scope(aTHX_ a,b,c)
 #   define croak_caller                         Perl_croak_caller
 #   define croak_no_mem                         Perl_croak_no_mem
+#   define croak_no_mem_ext                     Perl_croak_no_mem_ext
 #   define croak_popstack                       Perl_croak_popstack
 #   define custom_op_get_field(a,b)             Perl_custom_op_get_field(aTHX_ a,b)
 #   define cv_clone_into(a,b)                   Perl_cv_clone_into(aTHX_ a,b)

op.c

@@ -284,7 +284,7 @@ S_link_freed_op(pTHX_ OPSLAB *slab, OP *o) {
         slab->opslab_freed = (OP**)PerlMemShared_calloc((slab->opslab_freed_size), sizeof(OP*));
 
         if (!slab->opslab_freed)
-            croak_no_mem();
+            croak_no_mem_ext(STR_WITH_LEN("op:link_freed_op"));
     }
     else if (index >= slab->opslab_freed_size) {
         /* It's probably not worth doing exponential expansion here, the number of op sizes
@@ -295,7 +295,7 @@ S_link_freed_op(pTHX_ OPSLAB *slab, OP *o) {
         OP **p = (OP **)PerlMemShared_realloc(slab->opslab_freed, newsize * sizeof(OP*));
 
         if (!p)
-            croak_no_mem();
+            croak_no_mem_ext(STR_WITH_LEN("op:link_freed_op"));
 
         Zero(p+slab->opslab_freed_size, newsize - slab->opslab_freed_size, OP *);
 
@@ -15832,7 +15832,7 @@ Perl_rcpv_new(pTHX_ const char *pv, STRLEN len, U32 flags) {
 
     rcpv = (RCPV *)PerlMemShared_malloc(sizeof(struct rcpv) + len);
     if (!rcpv)
-        croak_no_mem();
+        croak_no_mem_ext(STR_WITH_LEN("op:rcpv_new"));
 
     rcpv->len = len;    /* store length including null,
                            RCPV_LEN() subtracts 1 to account for this */

os2/os2ish.h

@@ -192,7 +192,8 @@ extern int rc;
 #  define pthread_setspecific(k,v)	(*(k)=(v),0)
 #  define pthread_key_create(keyp,flag)			\
         ( DosAllocThreadLocalMemory(1,(unsigned long**)keyp)	\
-          ? Perl_croak_nocontext("Out of memory!"), 1        \
+          /* diag_listed_as: Out of memory in perl:%s */ \
+          ? Perl_croak_nocontext("Out of memory in perl:os2:pthread_key_create"), 1        \
           : 0						\
         )
 #endif /* USE_SLOW_THREAD_SPECIFIC */

perlio.c

@@ -2697,7 +2697,7 @@ S_more_refcounted_fds(pTHX_ const int new_fd)
 
     if (!new_array) {
         MUTEX_UNLOCK(&PL_perlio_mutex);
-        croak_no_mem();
+        croak_no_mem_ext(STR_WITH_LEN("perlio:more_refcounted_fds"));
     }
 
     PL_perlio_fd_refcnt_size = new_max;

pod/perldiag.pod

@@ -4892,12 +4892,28 @@ where the failed request happened.
 is most likely to be caused by a typo in the Perl program. e.g.,
 C<$arr[time]> instead of C<$arr[$time]>.
 
+=item Out of memory during vec in lvalue context
+
+(F) An attempt was made to extend a string beyond the largest possible memory
+allocation by assigning to C<vec()> called with a large second argument.
+
 =item Out of memory for yacc stack
 
 (F) The yacc parser wanted to grow its stack so it could continue
 parsing, but realloc() wouldn't give it more memory, virtual or
 otherwise.
 
+=item Out of memory in perl:%s
+
+(X) A low-level memory allocation routine failed, indicating there was
+insufficient remaining (virtual) memory to satisfy the request.  Perl has no
+option but to exit immediately.
+
+At least in Unix you may be able to get past this by increasing your process
+datasize limits: in csh/tcsh use C<limit> and C<limit datasize n> (where C<n>
+is the number of kilobytes) to check the current limits and change them, and in
+ksh/bash/zsh use C<ulimit -a> and C<ulimit -d n>, respectively.
+
 =item '.' outside of string in pack
 
 (F) The argument to a '.' in your template tried to move the working

t/op/vec.t

@@ -152,12 +152,12 @@ like($@, qr/^Modification of a read-only value attempted at /,
     # partially duplicates some tests above, but those cases are repeated
     # here for completeness.
     #
-    # Note that all the 'Out of memory!' errors trapped eval {} are 'fake'
-    # croaks generated by pp_vec() etc when they have detected something
-    # that would have otherwise overflowed. The real 'Out of memory!'
-    # error thrown by safesysrealloc() etc is not trappable. If it were
-    # accidentally triggered in this test script, the script would exit at
-    # that point.
+    # Note that all the 'Out of memory during vec in lvalue context' errors
+    # trapped by eval {} are 'fake' croaks generated by pp_vec() etc when they
+    # have detected something that would have otherwise overflowed. The real
+    # 'Out of memory!' error thrown by safesysrealloc() etc is not trappable.
+    # If it were accidentally triggered in this test script, the script would
+    # exit at that point.
 
 
     my $s = "abcdefghijklmnopqrstuvwxyz";
@@ -168,7 +168,7 @@ like($@, qr/^Modification of a read-only value attempted at /,
     $x = vec($s, ~0, 8);
     is($x, 0, "RT 130915: UV_MAX rval");
     eval { vec($s, ~0, 8) = 1 };
-    like($@, qr/^Out of memory!/, "RT 130915: UV_MAX lval");
+    like($@, qr/^Out of memory during vec in lvalue context/, "RT 130915: UV_MAX lval");
 
     # offset is negative
 
@@ -190,7 +190,7 @@ like($@, qr/^Modification of a read-only value attempted at /,
         $x = vec($s, $sm2, 8);
         is($x, 0, "RT 130915: size_max*2 rval");
         eval { vec($s, $sm2, 8) = 1 };
-        like($@, qr/^Out of memory!/, "RT 130915: size_max*2 lval");
+        like($@, qr/^Out of memory during vec in lvalue context/, "RT 130915: size_max*2 lval");
     }
 
     # (offset * num-bytes) could overflow
@@ -204,7 +204,7 @@ like($@, qr/^Modification of a read-only value attempted at /,
             $x = vec($s, $offset, $bytes*8);
             is($x, 0, "large offset: bytes=$bytes biglog2=$biglog2 i=$i: rval");
             eval { vec($s, $offset, $bytes*8) = 1; };
-            like($@, qr/^Out of memory!/,
+            like($@, qr/^Out of memory during vec in lvalue context/,
                       "large offset: bytes=$bytes biglog2=$biglog2 i=$i: rval");
         }
     }
@@ -247,7 +247,7 @@ like($@, qr/^Modification of a read-only value attempted at /,
     $v = RT131083(0, vec($s, $off, 8));
     is($v, 0, "RT131083 rval ~0");
     $v = eval { RT131083(1, vec($s, $off, 8)); };
-    like($@, qr/Out of memory!/, "RT131083 lval ~0");
+    like($@, qr/Out of memory during vec in lvalue context/, "RT131083 lval ~0");
 }
 
 {

util.c

@@ -205,7 +205,7 @@ Perl_safesysmalloc(MEM_SIZE size)
             if (PL_nomemok)
                 ptr =  NULL;
             else
-                croak_no_mem();
+                croak_no_mem_ext(STR_WITH_LEN("util:safesysmalloc"));
         }
     }
     return ptr;
@@ -340,7 +340,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
                 if (PL_nomemok)
                     ptr = NULL;
                 else
-                    croak_no_mem();
+                    croak_no_mem_ext(STR_WITH_LEN("util:safesysrealloc"));
             }
         }
     }
@@ -512,7 +512,7 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 #endif
         if (PL_nomemok)
             return NULL;
-        croak_no_mem();
+        croak_no_mem_ext(STR_WITH_LEN("util:safesyscalloc"));
     }
 }
 
@@ -1342,7 +1342,7 @@ Perl_savesharedpv(pTHX_ const char *pv)
     pvlen = strlen(pv)+1;
     newaddr = (char*)PerlMemShared_malloc(pvlen);
     if (!newaddr) {
-        croak_no_mem();
+        croak_no_mem_ext(STR_WITH_LEN("util:savesharedpv"));
     }
     return (char*)memcpy(newaddr, pv, pvlen);
 }
@@ -1365,7 +1365,7 @@ Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
     /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
 
     if (!newaddr) {
-        croak_no_mem();
+        croak_no_mem_ext(STR_WITH_LEN("util:savesharedpvn"));
     }
     newaddr[len] = '\0';
     return (char*)memcpy(newaddr, pv, len);
@@ -1970,20 +1970,35 @@ Perl_croak_no_modify(void)
    This is typically called when malloc returns NULL.
 */
 void
-Perl_croak_no_mem(void)
+Perl_croak_no_mem_ext(const char *context, STRLEN len)
 {
     dTHX;
 
+    PERL_ARGS_ASSERT_CROAK_NO_MEM_EXT;
+
     int fd = PerlIO_fileno(Perl_error_log);
     if (fd < 0)
         SETERRNO(EBADF,RMS_IFI);
     else {
         /* Can't use PerlIO to write as it allocates memory */
-        PERL_UNUSED_RESULT(PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1));
+        static const char oomp[] = "Out of memory in perl:";
+        if (
+            PerlLIO_write(fd, oomp, sizeof oomp - 1) >= 0
+            && PerlLIO_write(fd, context, len) >= 0
+            && PerlLIO_write(fd, "\n", 1) >= 0
+        ) {
+            /* nop */
+        }
     }
     my_exit(1);
 }
 
+void
+Perl_croak_no_mem(void)
+{
+    croak_no_mem_ext(STR_WITH_LEN("???"));
+}
+
 /* does not return, used only in POPSTACK */
 void
 Perl_croak_popstack(void)

win32/win32.c

@@ -131,7 +131,7 @@ static void	remove_dead_process(long child);
 static int	terminate_process(DWORD pid, HANDLE process_handle, int sig);
 static int	my_killpg(int pid, int sig);
 static int	my_kill(int pid, int sig);
-static void	out_of_memory(void);
+static void	out_of_memory(const char *context, STRLEN len);
 static char*	wstr_to_str(const wchar_t* wstr);
 static long	filetime_to_clock(PFILETIME ft);
 static BOOL	filetime_from_time(PFILETIME ft, time_t t);
@@ -2227,11 +2227,11 @@ win32_longpath(char *path)
 }
 
 static void
-out_of_memory(void)
+out_of_memory(const char *context, STRLEN len)
 {
 
     if (PL_curinterp)
-        croak_no_mem();
+        croak_no_mem_ext(context, len);
     exit(1);
 }
 
@@ -2255,7 +2255,7 @@ wstr_to_str(const wchar_t* wstr)
                                    NULL, 0, NULL, NULL);
     char* str = (char*)malloc(len);
     if (!str)
-        out_of_memory();
+        out_of_memory(STR_WITH_LEN("win32:wstr_to_str"));
     WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
                         str, len, NULL, &used_default);
     return str;
@@ -2288,7 +2288,7 @@ win32_ansipath(const WCHAR *widename)
                                   NULL, 0, NULL, NULL);
     name = (char*)win32_malloc(len);
     if (!name)
-        out_of_memory();
+        out_of_memory(STR_WITH_LEN("win32:win32_ansipath"));
 
     WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
                         name, len, NULL, &use_default);
@@ -2297,14 +2297,14 @@ win32_ansipath(const WCHAR *widename)
         if (shortlen) {
             WCHAR *shortname = (WCHAR*)win32_malloc(shortlen*sizeof(WCHAR));
             if (!shortname)
-                out_of_memory();
+                out_of_memory(STR_WITH_LEN("win32:win32_ansipath"));
             shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
 
             len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
                                       NULL, 0, NULL, NULL);
             name = (char*)win32_realloc(name, len);
             if (!name)
-                out_of_memory();
+                out_of_memory(STR_WITH_LEN("win32:win32_ansipath"));
             WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
                                 name, len, NULL, NULL);
             win32_free(shortname);
@@ -2337,7 +2337,7 @@ win32_getenvironmentstrings(void)
                                           lpWStr, wenvstrings_len, NULL, 0, NULL, NULL);
     lpTmp = lpStr = (char *)win32_calloc(aenvstrings_len, sizeof(char));
     if(!lpTmp)
-        out_of_memory();
+        out_of_memory(STR_WITH_LEN("win32:win32_getenvironmentstrings"));
 
     /* Convert the string from UTF-16 encoding to ACP encoding */
     WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, lpWStr, wenvstrings_len, lpStr,