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 (file)
--- 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 (file)
--- 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 (file)
--- 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<perlembed>.
 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 (file)
--- 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 (file)
--- 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 (file)
--- 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<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

diff --git a/sv.c b/sv.c
index babfe9d..a915dd9 100644 (file)
--- 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 (file)
--- 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;
     }