Change 29846 by [EMAIL PROTECTED] on 2007/01/17 11:36:40
Integrate:
[ 26474]
Create a struct to use as the header with PERL_TRACK_MEMPOOL, so that
other information can be stored in it.
[ 26476]
If PERL_TRACK_MEMPOOL and PERL_POISON are in use, then scribble all
over memory to invalidate it just before free()ing it.
[ 26478]
For PERL_TRACK_MEMPOOL with PERL_POISON, Poison the end of any block
being shrunk in realloc()
[ 27084]
Enhance PERL_TRACK_MEMPOOL so that it also emulates the PerlHost
behaviour of freeing up all memory at thread exit. With this and
tools such as valgrind you will now get warnings as soon as you
read from the deallocated memory, rather than just a warning much
later about freeing to the wrong pool.
[ 27088]
Don't export PL_memory_debug_header to Win32 (and others) unless
PERL_TRACK_MEMPOOL is defined.
[ 27151]
With PERL_POISON defined, ensure freshly malloc()ed memory isn't zeros,
and when PERL_TRACK_MEMPOOL is also defined scribble on any extension
added by realloc().
[ 27343]
Subject: [PATCH] PERL_TRACK_MEMPOOL cripples environment after exit()
From: Marcus Holland-Moritz <[EMAIL PROTECTED]>
Date: Sun, 26 Feb 2006 20:47:21 +0100
Message-ID: <[EMAIL PROTECTED]>
[ 27396]
Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
value as we're probably hunting memory leaks then
Affected files ...
... //depot/maint-5.8/perl/embedvar.h#57 integrate
... //depot/maint-5.8/perl/intrpvar.h#49 integrate
... //depot/maint-5.8/perl/makedef.pl#37 integrate
... //depot/maint-5.8/perl/miniperlmain.c#13 integrate
... //depot/maint-5.8/perl/perl.c#180 integrate
... //depot/maint-5.8/perl/perl.h#125 edit
... //depot/maint-5.8/perl/perlapi.h#49 integrate
... //depot/maint-5.8/perl/pod/perltodo.pod#25 integrate
... //depot/maint-5.8/perl/sv.c#280 integrate
... //depot/maint-5.8/perl/util.c#119 integrate
Differences ...
==== //depot/maint-5.8/perl/embedvar.h#57 (text+w) ====
Index: perl/embedvar.h
--- perl/embedvar.h#56~29759~ 2007-01-11 08:45:05.000000000 -0800
+++ perl/embedvar.h 2007-01-17 03:36:40.000000000 -0800
@@ -662,6 +662,7 @@
#define PL_max_intro_pending (vTHX->Imax_intro_pending)
#define PL_maxo (vTHX->Imaxo)
#define PL_maxsysfd (vTHX->Imaxsysfd)
+#define PL_memory_debug_header (vTHX->Imemory_debug_header)
#define PL_mess_sv (vTHX->Imess_sv)
#define PL_min_intro_pending (vTHX->Imin_intro_pending)
#define PL_minus_F (vTHX->Iminus_F)
@@ -994,6 +995,7 @@
#define PL_Imax_intro_pending PL_max_intro_pending
#define PL_Imaxo PL_maxo
#define PL_Imaxsysfd PL_maxsysfd
+#define PL_Imemory_debug_header PL_memory_debug_header
#define PL_Imess_sv PL_mess_sv
#define PL_Imin_intro_pending PL_min_intro_pending
#define PL_Iminus_F PL_minus_F
==== //depot/maint-5.8/perl/intrpvar.h#49 (text) ====
Index: perl/intrpvar.h
--- perl/intrpvar.h#48~28128~ 2006-05-08 12:22:03.000000000 -0700
+++ perl/intrpvar.h 2007-01-17 03:36:40.000000000 -0800
@@ -591,6 +591,11 @@
PERLVARI(Iutf8cache, I8, 1) /* Is the utf8 caching code enabled? */
#endif
+#ifdef PERL_TRACK_MEMPOOL
+/* For use with the memory debugging code in util.c */
+PERLVAR(Imemory_debug_header, struct perl_memory_debug_header)
+#endif
+
/* New variables must be added to the very end, before this comment,
* for binary compatibility (the offsets of the old members must not change).
* (Don't forget to add your variable also to perl_clone()!)
==== //depot/maint-5.8/perl/makedef.pl#37 (text) ====
Index: perl/makedef.pl
--- perl/makedef.pl#36~29759~ 2007-01-11 08:45:05.000000000 -0800
+++ perl/makedef.pl 2007-01-17 03:36:40.000000000 -0800
@@ -805,6 +805,12 @@
)];
}
+unless ($define{'PERL_TRACK_MEMPOOL'}) {
+ skip_symbols [qw(
+ PL_memory_debug_header
+ )];
+}
+
# Ideally this would also check SA_SIGINFO, but there doesn't seem to be an
# easy way to find that out from here. Fix it if it breaks because there is
# a platform where the logic here doesn't work, *and* the export lists have to
==== //depot/maint-5.8/perl/miniperlmain.c#13 (text) ====
Index: perl/miniperlmain.c
--- perl/miniperlmain.c#12~25673~ 2005-09-30 10:13:04.000000000 -0700
+++ perl/miniperlmain.c 2007-01-17 03:36:40.000000000 -0800
@@ -97,11 +97,24 @@
exitstatus = perl_parse(my_perl, xs_init, argc, argv, (char **)NULL);
if (!exitstatus)
perl_run(my_perl);
-
+
exitstatus = perl_destruct(my_perl);
perl_free(my_perl);
+#if defined(USE_ENVIRON_ARRAY) && defined(PERL_TRACK_MEMPOOL)
+ /*
+ * The old environment may have been freed by perl_free()
+ * when PERL_TRACK_MEMPOOL is defined, but without having
+ * been restored by perl_destruct() before (this is only
+ * done if destruct_level > 0).
+ *
+ * It is important to have a valid environment for atexit()
+ * routines that are eventually called.
+ */
+ environ = env;
+#endif
+
PERL_SYS_TERM();
exit(exitstatus);
==== //depot/maint-5.8/perl/perl.c#180 (text) ====
Index: perl/perl.c
--- perl/perl.c#179~29832~ 2007-01-15 08:30:37.000000000 -0800
+++ perl/perl.c 2007-01-17 03:36:40.000000000 -0800
@@ -195,6 +195,7 @@
PL_Dir = ipD;
PL_Sock = ipS;
PL_Proc = ipP;
+ INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
return my_perl;
}
@@ -222,7 +223,13 @@
my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
INIT_TLS_AND_INTERP;
+#ifndef PERL_TRACK_MEMPOOL
return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
+#else
+ Zero(my_perl, 1, PerlInterpreter);
+ INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
+ return my_perl;
+#endif
}
#endif /* PERL_IMPLICIT_SYS */
@@ -1382,6 +1389,22 @@
void
perl_free(pTHXx)
{
+#ifdef PERL_TRACK_MEMPOOL
+ {
+ /*
+ * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
+ * value as we're probably hunting memory leaks then
+ */
+ const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
+ if (!s || atoi(s) == 0) {
+ /* Emulate the PerlHost behaviour of free()ing all memory allocated
in this
+ thread at thread exit. */
+ while(aTHXx->Imemory_debug_header.next !=
&(aTHXx->Imemory_debug_header))
+ safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
+ }
+ }
+#endif
+
#if defined(WIN32) || defined(NETWARE)
# if defined(PERL_IMPLICIT_SYS)
# ifdef NETWARE
==== //depot/maint-5.8/perl/perl.h#125 (text) ====
Index: perl/perl.h
--- perl/perl.h#124~29800~ 2007-01-13 15:25:42.000000000 -0800
+++ perl/perl.h 2007-01-17 03:36:40.000000000 -0800
@@ -100,9 +100,12 @@
# endif
#endif
+
#ifdef PERL_IMPLICIT_CONTEXT
+
# ifdef USE_5005THREADS
struct perl_thread;
+# define tTHX register struct perl_thread *
# define pTHX register struct perl_thread *thr PERL_UNUSED_DECL
# define aTHX thr
# define dTHR dNOOP /* only backward compatibility */
@@ -112,7 +115,6 @@
# define MULTIPLICITY
# endif
# define tTHX PerlInterpreter*
-# define sTHX (sizeof(tTHX) + (MEM_ALIGNBYTES -
sizeof(tTHX)%MEM_ALIGNBYTES) % MEM_ALIGNBYTES)
# define pTHX register PerlInterpreter *my_perl PERL_UNUSED_DECL
# define aTHX my_perl
# define dTHXa(a) pTHX = (tTHX)a
@@ -3716,6 +3718,34 @@
# define MALLOC_TERM
#endif
+#if defined(PERL_IMPLICIT_CONTEXT)
+
+struct perl_memory_debug_header;
+struct perl_memory_debug_header {
+ tTHX interpreter;
+# ifdef PERL_POISON
+ MEM_SIZE size;
+# endif
+ struct perl_memory_debug_header *prev;
+ struct perl_memory_debug_header *next;
+};
+
+# define sTHX (sizeof(struct perl_memory_debug_header) + \
+ (MEM_ALIGNBYTES - sizeof(struct perl_memory_debug_header) \
+ %MEM_ALIGNBYTES) % MEM_ALIGNBYTES)
+
+#endif
+
+#ifdef PERL_TRACK_MEMPOOL
+# define INIT_TRACK_MEMPOOL(header, interp) \
+ STMT_START { \
+ (header).interpreter = (interp); \
+ (header).prev = (header).next = &(header); \
+ } STMT_END
+# else
+# define INIT_TRACK_MEMPOOL(header, interp)
+#endif
+
typedef int (CPERLscope(*runops_proc_t)) (pTHX);
typedef void (CPERLscope(*share_proc_t)) (pTHX_ SV *sv);
==== //depot/maint-5.8/perl/perlapi.h#49 (text+w) ====
Index: perl/perlapi.h
--- perl/perlapi.h#48~29759~ 2007-01-11 08:45:05.000000000 -0800
+++ perl/perlapi.h 2007-01-17 03:36:40.000000000 -0800
@@ -405,6 +405,8 @@
#define PL_maxo (*Perl_Imaxo_ptr(aTHX))
#undef PL_maxsysfd
#define PL_maxsysfd (*Perl_Imaxsysfd_ptr(aTHX))
+#undef PL_memory_debug_header
+#define PL_memory_debug_header (*Perl_Imemory_debug_header_ptr(aTHX))
#undef PL_mess_sv
#define PL_mess_sv (*Perl_Imess_sv_ptr(aTHX))
#undef PL_min_intro_pending
==== //depot/maint-5.8/perl/pod/perltodo.pod#25 (text) ====
Index: perl/pod/perltodo.pod
--- perl/pod/perltodo.pod#24~28130~ 2006-05-08 13:44:45.000000000 -0700
+++ perl/pod/perltodo.pod 2007-01-17 03:36:40.000000000 -0800
@@ -373,38 +373,6 @@
might want to determine what ops I<really> are the most commonly used. And in
turn suggest evictions and promotions to achieve a better F<pp_hot.c>.
-=head2 emulate the per-thread memory pool on Unix
-
-For Windows, ithreads allocates memory for each thread from a separate pool,
-which it discards at thread exit. It also checks that memory is free()d to
-the correct pool. Neither check is done on Unix, so code developed there won't
-be subject to such strictures, so can harbour bugs that only show up when the
-code reaches Windows.
-
-It would be good to be able to optionally emulate the Window pool system on
-Unix, to let developers who only have access to Unix, or want to use
-Unix-specific debugging tools, check for these problems. To do this would
-involve figuring out how the C<PerlMem_*> macros wrap C<malloc()> access, and
-providing a layer that records/checks the identity of the thread making the
-call, and recording all the memory allocated by each thread via this API so
-that it can be summarily free()d at thread exit. One implementation idea
-would be to increase the size of allocation, and store the C<my_perl> pointer
-(to identify the thread) at the start, along with pointers to make a linked
-list of blocks for this thread. To avoid alignment problems it would be
-necessary to do something like
-
- union memory_header_padded {
- struct memory_header {
- void *thread_id; /* For my_perl */
- void *next; /* Pointer to next block for this thread */
- } data;
- long double padding; /* whatever type has maximal alignment constraint */
- };
-
-
-although C<long double> might not be the only type to add to the padding
-union.
-
=head2 reduce duplication in sv_setsv_flags
C<Perl_sv_setsv_flags> has a comment
==== //depot/maint-5.8/perl/sv.c#280 (text) ====
Index: perl/sv.c
--- perl/sv.c#279~29807~ 2007-01-14 05:09:22.000000000 -0800
+++ perl/sv.c 2007-01-17 03:36:40.000000000 -0800
@@ -10102,6 +10102,7 @@
param->flags = flags;
param->proto_perl = proto_perl;
+ INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
/* arena roots */
PL_body_arenas = NULL;
==== //depot/maint-5.8/perl/util.c#119 (text) ====
Index: perl/util.c
--- perl/util.c#118~29809~ 2007-01-14 05:47:07.000000000 -0800
+++ perl/util.c 2007-01-17 03:36:40.000000000 -0800
@@ -93,7 +93,24 @@
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld
bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
if (ptr != NULL) {
#ifdef PERL_TRACK_MEMPOOL
- *(tTHX*)ptr = aTHX;
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)ptr;
+#endif
+
+#ifdef PERL_POISON
+ Poison(((char *)ptr), size, char);
+#endif
+
+#ifdef PERL_TRACK_MEMPOOL
+ header->interpreter = aTHX;
+ /* Link us into the list. */
+ header->prev = &PL_memory_debug_header;
+ header->next = PL_memory_debug_header.next;
+ PL_memory_debug_header.next = header;
+ header->next->prev = header;
+# ifdef PERL_POISON
+ header->size = size;
+# endif
ptr = (Malloc_t)((char*)ptr+sTHX);
#endif
return ptr;
@@ -134,8 +151,23 @@
#ifdef PERL_TRACK_MEMPOOL
where = (Malloc_t)((char*)where-sTHX);
size += sTHX;
- if (*(tTHX*)where != aTHX) {
- Perl_croak_nocontext("panic: realloc from wrong pool");
+ {
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)where;
+
+ if (header->interpreter != aTHX) {
+ Perl_croak_nocontext("panic: realloc from wrong pool");
+ }
+ assert(header->next->prev == header);
+ assert(header->prev->next == header);
+# ifdef PERL_POISON
+ if (header->size > size) {
+ const MEM_SIZE freed_up = header->size - size;
+ char *start_of_freed = ((char *)where) + size;
+ Poison(start_of_freed, freed_up, char);
+ }
+ header->size = size;
+# endif
}
#endif
#ifdef DEBUGGING
@@ -150,6 +182,20 @@
if (ptr != NULL) {
#ifdef PERL_TRACK_MEMPOOL
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)ptr;
+
+# ifdef PERL_POISON
+ if (header->size < size) {
+ const MEM_SIZE fresh = size - header->size;
+ char *start_of_fresh = ((char *)ptr) + size;
+ Poison(start_of_fresh, fresh, char);
+ }
+# endif
+
+ header->next->prev = header;
+ header->prev->next = header;
+
ptr = (Malloc_t)((char*)ptr+sTHX);
#endif
return ptr;
@@ -174,8 +220,28 @@
if (where) {
#ifdef PERL_TRACK_MEMPOOL
where = (Malloc_t)((char*)where-sTHX);
- if (*(tTHX*)where != aTHX) {
- Perl_croak_nocontext("panic: free from wrong pool");
+ {
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)where;
+
+ if (header->interpreter != aTHX) {
+ Perl_croak_nocontext("panic: free from wrong pool");
+ }
+ if (!header->prev) {
+ Perl_croak_nocontext("panic: duplicate free");
+ }
+ if (!(header->next) || header->next->prev != header
+ || header->prev->next != header) {
+ Perl_croak_nocontext("panic: bad free");
+ }
+ /* Unlink us from the chain. */
+ header->next->prev = header->prev;
+ header->prev->next = header->next;
+# ifdef PERL_POISON
+ Poison(where, header->size, char);
+# endif
+ /* Trigger the duplicate free warning. */
+ header->next = NULL;
}
#endif
PerlMem_free(where);
@@ -211,8 +277,21 @@
if (ptr != NULL) {
memset((void*)ptr, 0, size);
#ifdef PERL_TRACK_MEMPOOL
- *(tTHX*)ptr = aTHX;
- ptr = (Malloc_t)((char*)ptr+sTHX);
+ {
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)ptr;
+
+ header->interpreter = aTHX;
+ /* Link us into the list. */
+ header->prev = &PL_memory_debug_header;
+ header->next = PL_memory_debug_header.next;
+ PL_memory_debug_header.next = header;
+ header->next->prev = header;
+# ifdef PERL_POISON
+ header->size = size;
+# endif
+ ptr = (Malloc_t)((char*)ptr+sTHX);
+ }
#endif
return ptr;
}
End of Patch.