63 lines
2.2 KiB
Plaintext
63 lines
2.2 KiB
Plaintext
Fix a segmentation fault with 'debugperl -Dm'. Upstream change 33388.
|
|
|
|
diff --git a/perl.c b/perl.c
|
|
index e0bc0e7..c5a2070 100644
|
|
--- a/perl.c
|
|
+++ b/perl.c
|
|
@@ -1364,10 +1364,17 @@ perl_free(pTHXx)
|
|
*/
|
|
const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
|
|
if (!s || atoi(s) == 0) {
|
|
+ const U32 old_debug = PL_debug;
|
|
/* Emulate the PerlHost behaviour of free()ing all memory allocated in this
|
|
thread at thread exit. */
|
|
+ if (DEBUG_m_TEST) {
|
|
+ PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we "
|
|
+ "free this thread's memory\n");
|
|
+ PL_debug &= ~ DEBUG_m_FLAG;
|
|
+ }
|
|
while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
|
|
safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
|
|
+ PL_debug = old_debug;
|
|
}
|
|
}
|
|
#endif
|
|
diff --git a/util.c b/util.c
|
|
index 62fd7ba..d8796cf 100644
|
|
--- a/util.c
|
|
+++ b/util.c
|
|
@@ -178,11 +178,11 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
|
|
ptr = (Malloc_t)PerlMem_realloc(where,size);
|
|
PERL_ALLOC_CHECK(ptr);
|
|
|
|
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
|
|
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
|
|
-
|
|
- if (ptr != NULL) {
|
|
+ /* MUST do this fixup first, before doing ANYTHING else, as anything else
|
|
+ might allocate memory/free/move memory, and until we do the fixup, it
|
|
+ may well be chasing (and writing to) free memory. */
|
|
#ifdef PERL_TRACK_MEMPOOL
|
|
+ if (ptr != NULL) {
|
|
struct perl_memory_debug_header *const header
|
|
= (struct perl_memory_debug_header *)ptr;
|
|
|
|
@@ -198,7 +198,17 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
|
|
header->prev->next = header;
|
|
|
|
ptr = (Malloc_t)((char*)ptr+sTHX);
|
|
+ }
|
|
#endif
|
|
+
|
|
+ /* In particular, must do that fixup above before logging anything via
|
|
+ *printf(), as it can reallocate memory, which can cause SEGVs. */
|
|
+
|
|
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
|
|
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
|
|
+
|
|
+
|
|
+ if (ptr != NULL) {
|
|
return ptr;
|
|
}
|
|
else if (PL_nomemok)
|