From: Nicholas Clark Date: Sat, 4 Feb 2006 19:09:17 +0000 (+0000) Subject: Enhance PERL_TRACK_MEMPOOL so that it also emulates the PerlHost X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7cb608b5fc09aa914d5f91646e40ed772b6bac01;p=p5sagit%2Fp5-mst-13.2.git 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. p4raw-id: //depot/perl@27084 --- diff --git a/embedvar.h b/embedvar.h index f2e09eb..022dce8 100644 --- a/embedvar.h +++ b/embedvar.h @@ -304,6 +304,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_E (vTHX->Iminus_E) @@ -584,6 +585,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_E PL_minus_E diff --git a/intrpvar.h b/intrpvar.h index dc5868a..79ad7de 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -525,6 +525,11 @@ PERLVARI(Imy_cxt_size, int, 0) /* size of PL_my_cxt_list */ PERLVARI(Imy_cxt_list, void **, NULL) /* per-module array of MY_CXT pointers */ #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()!) diff --git a/perl.c b/perl.c index 411caea..48ddb7a 100644 --- a/perl.c +++ b/perl.c @@ -181,6 +181,7 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, PL_Dir = ipD; PL_Sock = ipS; PL_Proc = ipP; + INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl); return my_perl; } @@ -205,7 +206,13 @@ perl_alloc(void) my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); S_init_tls_and_interp(my_perl); +#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 */ @@ -1280,6 +1287,13 @@ Releases a Perl interpreter. See L. void perl_free(pTHXx) { +#ifdef PERL_TRACK_MEMPOOL + /* 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 diff --git a/perl.h b/perl.h index cf5e0bf..8a91175 100644 --- a/perl.h +++ b/perl.h @@ -3728,15 +3728,15 @@ typedef Sighandler_t Sigsave_t; #endif #if defined(PERL_IMPLICIT_CONTEXT) + +struct perl_memory_debug_header; struct perl_memory_debug_header { tTHX interpreter; # ifdef PERL_POISON MEM_SIZE size; - U8 in_use; # endif - -#define PERL_POISON_INUSE 29 -#define PERL_POISON_FREE 159 + struct perl_memory_debug_header *prev; + struct perl_memory_debug_header *next; }; # define sTHX (sizeof(struct perl_memory_debug_header) + \ @@ -3745,6 +3745,16 @@ struct perl_memory_debug_header { #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); diff --git a/perlapi.h b/perlapi.h index ad1a2ef..fa28363 100644 --- a/perlapi.h +++ b/perlapi.h @@ -406,6 +406,8 @@ END_EXTERN_C #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 diff --git a/pod/perltodo.pod b/pod/perltodo.pod index d8d8a00..2be4e68 100644 --- a/pod/perltodo.pod +++ b/pod/perltodo.pod @@ -367,38 +367,6 @@ anyone feeling like exercising their skill with coverage and profiling tools might want to determine what ops I are the most commonly used. And in turn suggest evictions and promotions to achieve a better F. -=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 macros wrap C 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 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 might not be the only type to add to the padding -union. - =head2 reduce duplication in sv_setsv_flags C has a comment diff --git a/sv.c b/sv.c index babfe9d..a915dd9 100644 --- a/sv.c +++ b/sv.c @@ -10395,6 +10395,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, param->flags = flags; param->proto_perl = proto_perl; + INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl); + PL_body_arenas = NULL; Zero(&PL_body_roots, 1, PL_body_roots); diff --git a/util.c b/util.c index 9370b84..420232c 100644 --- a/util.c +++ b/util.c @@ -94,10 +94,17 @@ Perl_safesysmalloc(MEM_SIZE size) 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 - ((struct perl_memory_debug_header *)ptr)->interpreter = aTHX; + 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 - ((struct perl_memory_debug_header *)ptr)->size = size; - ((struct perl_memory_debug_header *)ptr)->in_use = PERL_POISON_INUSE; + header->size = size; # endif ptr = (Malloc_t)((char*)ptr+sTHX); #endif @@ -139,18 +146,24 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) #ifdef PERL_TRACK_MEMPOOL where = (Malloc_t)((char*)where-sTHX); size += sTHX; - if (((struct perl_memory_debug_header *)where)->interpreter != 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 (((struct perl_memory_debug_header *)where)->size > size) { - const MEM_SIZE freed_up = - ((struct perl_memory_debug_header *)where)->size - size; - char *start_of_freed = ((char *)where) + size; - Poison(start_of_freed, freed_up, char); - } - ((struct perl_memory_debug_header *)where)->size = size; + 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 if ((long)size < 0) @@ -164,6 +177,12 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) if (ptr != NULL) { #ifdef PERL_TRACK_MEMPOOL + struct perl_memory_debug_header *const header + = (struct perl_memory_debug_header *)ptr; + + header->next->prev = header; + header->prev->next = header; + ptr = (Malloc_t)((char*)ptr+sTHX); #endif return ptr; @@ -190,24 +209,29 @@ Perl_safesysfree(Malloc_t where) if (where) { #ifdef PERL_TRACK_MEMPOOL where = (Malloc_t)((char*)where-sTHX); - if (((struct perl_memory_debug_header *)where)->interpreter != aTHX) { - Perl_croak_nocontext("panic: free from wrong pool"); - } -# ifdef PERL_POISON { - if (((struct perl_memory_debug_header *)where)->in_use - == PERL_POISON_FREE) { + 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 (((struct perl_memory_debug_header *)where)->in_use - != PERL_POISON_INUSE) { - Perl_croak_nocontext("panic: bad free "); + if (!(header->next) || header->next->prev != header + || header->prev->next != header) { + Perl_croak_nocontext("panic: bad free"); } - ((struct perl_memory_debug_header *)where)->in_use - = PERL_POISON_FREE; - } - Poison(where, ((struct perl_memory_debug_header *)where)->size, char); + /* 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); } @@ -242,12 +266,21 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) if (ptr != NULL) { memset((void*)ptr, 0, size); #ifdef PERL_TRACK_MEMPOOL - ((struct perl_memory_debug_header *)ptr)->interpreter = aTHX; + { + 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 - ((struct perl_memory_debug_header *)ptr)->size = size; - ((struct perl_memory_debug_header *)ptr)->in_use = PERL_POISON_INUSE; + header->size = size; # endif - ptr = (Malloc_t)((char*)ptr+sTHX); + ptr = (Malloc_t)((char*)ptr+sTHX); + } #endif return ptr; }