8 files changed, 102 insertions, 66 deletions
diff --git a/embedvar.h b/embedvar.h
index f2e09eb963..022dce8c80 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 dc5868a1e8..79ad7de40d 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 411caea108..48ddb7abae 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<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 cf5e0bfcdd..8a91175ef1 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 ad1a2efc08..fa28363d96 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 d8d8a007ed..2be4e68d08 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<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 babfe9de41..a915dd913b 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 9370b84cbd..420232c4db 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;
     }