Reworked PERL_TRACK_MEMPOOL patch

From: "Jan Dubois" <jand@ActiveState.com>
Message-ID: <003601c5ec77$a45eb260$2217a8c0@candy>

p4raw-id: //depot/perl@26177

diff --git a/perl.h b/perl.h
index 172f96b..39e4f6e 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -148,12 +148,14 @@
 #  ifndef MULTIPLICITY
 #    define MULTIPLICITY
 #  endif
-#  define pTHX register PerlInterpreter *my_perl PERL_UNUSED_DECL
+#  define tTHX PerlInterpreter*
+#  define sTHX (sizeof(tTHX) + (MEM_ALIGNBYTES - sizeof(tTHX)%MEM_ALIGNBYTES) % MEM_ALIGNBYTES)
+#  define pTHX register tTHX my_perl PERL_UNUSED_DECL
 #  define aTHX my_perl
 #  ifdef PERL_GLOBAL_STRUCT
-#    define dTHXa(a)   dVAR; pTHX = (PerlInterpreter*)a
+#    define dTHXa(a)   dVAR; pTHX = (tTHX)a
 #  else
-#    define dTHXa(a)   pTHX = (PerlInterpreter*)a
+#    define dTHXa(a)   pTHX = (tTHX)a
 #  endif
 #  ifdef PERL_GLOBAL_STRUCT
 #    define dTHX               dVAR; pTHX = PERL_GET_THX
@@ -171,6 +173,11 @@
 #  define pTHX_7       8
 #  define pTHX_8       9
 #  define pTHX_9       10
+#  if defined(DEBUGGING) && !defined(PERL_TRACK_MEMPOOL)
+#    define PERL_TRACK_MEMPOOL
+#  endif
+#else
+#  undef PERL_TRACK_MEMPOOL
 #endif
 
 #define STATIC static
@@ -231,6 +238,9 @@
 #define dNOOP extern int Perl___notused PERL_UNUSED_DECL
 
 #ifndef pTHX
+/* Don't bother defining tTHX and sTHX; using them outside
+ * code guarded by PERL_IMPLICIT_CONTEXT is an error.
+ */
 #  define pTHX         void
 #  define pTHX_
 #  define aTHX

diff --git a/util.c b/util.c
index 67ed393..d344d1c 100644 (file)
--- a/util.c
+++ b/util.c
@@ -81,6 +81,9 @@ Perl_safesysmalloc(MEM_SIZE size)
            my_exit(1);
        }
 #endif /* HAS_64K_LIMIT */
+#ifdef PERL_TRACK_MEMPOOL
+    size += sTHX;
+#endif
 #ifdef DEBUGGING
     if ((long)size < 0)
        Perl_croak_nocontext("panic: malloc");
@@ -88,8 +91,13 @@ Perl_safesysmalloc(MEM_SIZE size)
     ptr = (Malloc_t)PerlMem_malloc(size?size:1);       /* malloc(0) is NASTY on our system */
     PERL_ALLOC_CHECK(ptr);
     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
-    if (ptr != Nullch)
+    if (ptr != Nullch) {
+#ifdef PERL_TRACK_MEMPOOL
+        *(tTHX*)ptr = aTHX;
+        ptr = (Malloc_t)((char*)ptr+sTHX);
+#endif
        return ptr;
+}
     else if (PL_nomemok)
        return Nullch;
     else {
@@ -123,6 +131,14 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 
     if (!where)
        return safesysmalloc(size);
+#ifdef PERL_TRACK_MEMPOOL
+    where = (Malloc_t)((char*)where-sTHX);
+    size += sTHX;
+    if (*(tTHX*)where != aTHX) {
+       /* int *nowhere = NULL; *nowhere = 0; */
+        Perl_croak_nocontext("panic: realloc from wrong pool");
+    }
+#endif
 #ifdef DEBUGGING
     if ((long)size < 0)
        Perl_croak_nocontext("panic: realloc");
@@ -133,8 +149,12 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
     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 != Nullch)
+    if (ptr != Nullch) {
+#ifdef PERL_TRACK_MEMPOOL
+        ptr = (Malloc_t)((char*)ptr+sTHX);
+#endif
        return ptr;
+    }
     else if (PL_nomemok)
        return Nullch;
     else {
@@ -149,11 +169,18 @@ Free_t
 Perl_safesysfree(Malloc_t where)
 {
     dVAR;
-#ifdef PERL_IMPLICIT_SYS
+#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
     dTHX;
 #endif
     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
     if (where) {
+#ifdef PERL_TRACK_MEMPOOL
+        where = (Malloc_t)((char*)where-sTHX);
+        if (*(tTHX*)where != aTHX) {
+           /* int *nowhere = NULL; *nowhere = 0; */
+            Perl_croak_nocontext("panic: free from wrong pool");
+       }
+#endif
        PerlMem_free(where);
     }
 }
@@ -178,11 +205,18 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
        Perl_croak_nocontext("panic: calloc");
 #endif
     size *= count;
+#ifdef PERL_TRACK_MEMPOOL
+    size += sTHX;
+#endif
     ptr = (Malloc_t)PerlMem_malloc(size?size:1);       /* malloc(0) is NASTY on our system */
     PERL_ALLOC_CHECK(ptr);
     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size));
     if (ptr != Nullch) {
        memset((void*)ptr, 0, size);
+#ifdef PERL_TRACK_MEMPOOL
+        *(tTHX*)ptr = aTHX;
+        ptr = (Malloc_t)((char*)ptr+sTHX);
+#endif
        return ptr;
     }
     else if (PL_nomemok)