From 8fbf04a996ed5aabbe92178be8aabfc9d7f1d890 Mon Sep 17 00:00:00 2001 From: Lukas Mai Date: Mon, 27 Nov 2023 17:44:42 +0100 Subject: [PATCH] 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 | 4 ++-- embed.fnc | 3 +++ embed.h | 1 + op.c | 6 +++--- os2/os2ish.h | 3 ++- perlio.c | 2 +- pod/perldiag.pod | 16 ++++++++++++++++ proto.h | 7 +++++++ t/op/vec.t | 20 ++++++++++---------- util.c | 29 ++++++++++++++++++++++------- win32/win32.c | 16 ++++++++-------- 11 files changed, 75 insertions(+), 32 deletions(-) diff --git a/doop.c b/doop.c index 0e2cfe19e6df..c611b6ed86fd 100644 --- a/doop.c +++ b/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; } diff --git a/embed.fnc b/embed.fnc index 01e768d46842..dce101488f48 100644 --- a/embed.fnc +++ b/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 diff --git a/embed.h b/embed.h index f6e01ab9a526..d4540278fe33 100644 --- a/embed.h +++ b/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) diff --git a/op.c b/op.c index 685542821093..8d8574d3e950 100644 --- a/op.c +++ 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 */ diff --git a/os2/os2ish.h b/os2/os2ish.h index b810900df782..c0f09cadb72e 100644 --- a/os2/os2ish.h +++ b/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 */ diff --git a/perlio.c b/perlio.c index 087644813c5b..87561915cad8 100644 --- a/perlio.c +++ b/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; diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 35de588c4fc8..f25f35af8ad8 100644 --- a/pod/perldiag.pod +++ b/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 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 and C (where C +is the number of kilobytes) to check the current limits and change them, and in +ksh/bash/zsh use C and C, respectively. + =item '.' outside of string in pack (F) The argument to a '.' in your template tried to move the working diff --git a/proto.h b/proto.h index 76991d227612..0ef3706ab076 100644 --- a/proto.h +++ b/proto.h @@ -624,6 +624,13 @@ Perl_croak_no_mem(void) __attribute__visibility__("hidden"); #define PERL_ARGS_ASSERT_CROAK_NO_MEM +PERL_CALLCONV_NO_RET void +Perl_croak_no_mem_ext(const char *context, STRLEN len) + __attribute__noreturn__ + __attribute__visibility__("hidden"); +#define PERL_ARGS_ASSERT_CROAK_NO_MEM_EXT \ + assert(context) + PERL_CALLCONV_NO_RET void Perl_croak_no_modify(void) __attribute__noreturn__; diff --git a/t/op/vec.t b/t/op/vec.t index d7872d97f1d6..41da760aafab 100644 --- a/t/op/vec.t +++ b/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"); } { diff --git a/util.c b/util.c index b6cc08fcf1cf..5df11e27a9c7 100644 --- a/util.c +++ b/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) diff --git a/win32/win32.c b/win32/win32.c index 5d54cf8d4a7d..2e62bc04482b 100644 --- a/win32/win32.c +++ b/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,