[prev in list] [next in list] [prev in thread] [next in thread] 

List:       perl5-changes
Subject:    [perl.git]  branch sprout/rocoy, updated. v5.19.7-77-gf212066
From:       "Father Chrysostomos" <sprout () cpan ! org>
Date:       2014-01-17 1:48:49
Message-ID: E1W3yYD-00059E-Jg () camel ! ams6 ! corp ! booking ! com
[Download RAW message or body]

In perl.git, the branch sprout/rocoy has been updated

<http://perl5.git.perl.org/perl.git/commitdiff/f212066e0475936eb714d69457d7e43a4655c364?hp=080dc6b45f1449e70629d54dd2587ee345613271>


- Log -----------------------------------------------------------------
commit f212066e0475936eb714d69457d7e43a4655c364
Author: Father Chrysostomos <sprout@cpan.org>
Date:   Mon Jan 13 22:02:37 2014 -0800

    fixups for non-threaded buidls

M	sv.c
M	util.c

commit 0fd6a76670a96dbf69a9805cb07285b581bf035d
Author: Father Chrysostomos <sprout@cpan.org>
Date:   Mon Jan 13 20:37:33 2014 -0800

    uniprops.t fixup

M	t/re/uniprops.t

commit 35a5fe1fa57324e87d07172a3c170924af21b548
Author: Father Chrysostomos <sprout@cpan.org>
Date:   Sat Jan 11 16:45:18 2014 -0800

    util.c: A couple of defines to simplify #ifdef maze
    
    No real simplification in terms of the number of #ifdefs, but more
    readability (hopefully).

M	util.c

commit 13ec61dcd3afcb0433496286ef9b644fca0ffacd
Author: Father Chrysostomos <sprout@cpan.org>
Date:   Sat Jan 11 16:36:15 2014 -0800

    More poison fixups

M	util.c

commit 25f35f0f3145ed1965a10c362ce05412c9afbc66
Author: Father Chrysostomos <sprout@cpan.org>
Date:   Sat Jan 11 16:22:50 2014 -0800

    fixups

M	util.c

commit d0b21cdd17c74955d386b2dffd54a07794214013
Author: Father Chrysostomos <sprout@cpan.org>
Date:   Sat Jan 11 16:22:02 2014 -0800

    safesyscalloc must support rocow
    
    We cannot just delegate to safesysmalloc, as PERL_POISON will
    poison the buffer newly zeroed by mmap.

M	util.c

commit fe1ec8acc710f2ae651ed6ee2870ce30e3665ad9
Author: Father Chrysostomos <sprout@cpan.org>
Date:   Sat Jan 11 11:14:18 2014 -0800

    Use sTHX

M	perl.c
M	perl.h
M	sv.c
M	util.c

commit 2d2035d7fc31a1cc054ebeaa1baaad747c7b6a90
Author: Father Chrysostomos <sprout@cpan.org>
Date:   Sun Jan 5 16:20:58 2014 -0800

    threads.t: Increase watchdog timeout
    
    PERL_DEBUG_READONLY_COW is too slow for a 60s timeout.

M	t/op/threads.t

commit 9882699e7ce48df9fd50f2f79f08a0478d2722eb
Author: Father Chrysostomos <sprout@cpan.org>
Date:   Sun Jan 5 16:09:35 2014 -0800

    Make XS::APItest::establish_cleanup protect existing stacks
    
    It causes pp_entersub to be called in odd places, which can cause the
    context stack to be reallocated when an outer function call (like
    pp_leavesub) has a pointer into the context stack in a C auto.
    
    cleanup.t was failing for me under PERL_DEBUG_READONLY_COW +
    STRESS_REALLOC + threads, because the context stack was reallocated
    and the old address then freed and reused for something else, being
    zeroed in the mean time.  So pp_leavesub returned NULL (trying to
    read retop from the context stack), causing the program to exit.
    During global destruction, subs that had not be exited properly were
    undefined, leading to:
    
    1..3
    Can't undef active subroutine during global destruction.

M	ext/XS-APItest/APItest.xs
-----------------------------------------------------------------------

Summary of changes:
 ext/XS-APItest/APItest.xs |   2 +
 perl.c                    |   6 +-
 perl.h                    |  27 +++++++-
 sv.c                      |  30 ++++++---
 t/op/threads.t            |   2 +-
 t/re/uniprops.t           |   1 -
 util.c                    | 152 ++++++++++++++++++++++++++++++----------------
 7 files changed, 151 insertions(+), 69 deletions(-)

diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index bed8ec3..21a536a 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -532,12 +532,14 @@ STATIC void
 THX_run_cleanup(pTHX_ void *cleanup_code_ref)
 {
     dSP;
+    PUSHSTACK;
     ENTER;
     SAVETMPS;
     PUSHMARK(SP);
     call_sv((SV*)cleanup_code_ref, G_VOID|G_DISCARD);
     FREETMPS;
     LEAVE;
+    POPSTACK;
 }
 
 STATIC OP *
diff --git a/perl.c b/perl.c
index 7a13310..8271915 100644
--- a/perl.c
+++ b/perl.c
@@ -1349,11 +1349,7 @@ perl_free(pTHXx)
 		PL_debug &= ~ DEBUG_m_FLAG;
 	    }
 	    while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
-		safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next)
-# ifdef PERL_DEBUG_READONLY_COW
-				+ sizeof(IV)
-# endif
-		);
+		safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
 	    PL_debug = old_debug;
 	}
     }
diff --git a/perl.h b/perl.h
index b5af943..ab2b028 100644
--- a/perl.h
+++ b/perl.h
@@ -4015,13 +4015,27 @@ EXTERN_C void PerlIO_teardown(void);
 struct perl_memory_debug_header;
 struct perl_memory_debug_header {
   tTHX	interpreter;
-#  ifdef PERL_POISON
+#  if defined(PERL_POISON) || defined(PERL_DEBUG_READONLY_COW)
   MEM_SIZE size;
 #  endif
   struct perl_memory_debug_header *prev;
   struct perl_memory_debug_header *next;
+#  ifdef PERL_DEBUG_READONLY_COW
+  bool readonly;
+#  endif
+};
+
+#elif defined(PERL_DEBUG_READONLY_COW)
+
+struct perl_memory_debug_header;
+struct perl_memory_debug_header {
+  MEM_SIZE size;
 };
 
+#endif
+
+#if defined (PERL_IMPLICIT_CONTEXT) || defined (PERL_DEBUG_READONLY_COW)
+
 #  define sTHX	(sizeof(struct perl_memory_debug_header) + \
 	(MEM_ALIGNBYTES - sizeof(struct perl_memory_debug_header) \
 	 %MEM_ALIGNBYTES) % MEM_ALIGNBYTES)
@@ -4031,12 +4045,21 @@ struct perl_memory_debug_header {
 #endif
 
 #ifdef PERL_TRACK_MEMPOOL
+# ifdef PERL_DEBUG_READONLY_COW
 #  define INIT_TRACK_MEMPOOL(header, interp)			\
 	STMT_START {						\
 		(header).interpreter = (interp);		\
 		(header).prev = (header).next = &(header);	\
+		(header).readonly = 0;				\
 	} STMT_END
-#  else
+# else
+#  define INIT_TRACK_MEMPOOL(header, interp)			\
+	STMT_START {						\
+		(header).interpreter = (interp);		\
+		(header).prev = (header).next = &(header);	\
+	} STMT_END
+# endif
+# else
 #  define INIT_TRACK_MEMPOOL(header, interp)
 #endif
 
diff --git a/sv.c b/sv.c
index 4bcaac9..f950317 100644
--- a/sv.c
+++ b/sv.c
@@ -4048,26 +4048,38 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
 #ifdef PERL_DEBUG_READONLY_COW
 # include <sys/mman.h>
 
+# ifndef sTHX
+#  define sTHX 0
+# endif
+
 void
 Perl_sv_buf_to_ro(pTHX_ SV *sv)
 {
-    char * const buf = SvPVX(sv)-sizeof(IV);
-    const size_t len = (size_t)*(IV *)buf;
+    struct perl_memory_debug_header * const header =
+	(struct perl_memory_debug_header *)(SvPVX(sv)-sTHX);
+    const MEM_SIZE len = header->size;
     PERL_ARGS_ASSERT_SV_BUF_TO_RO;
-    if (mprotect(buf, len, PROT_READ))
+# ifdef PERL_TRACK_MEMPOOL
+    if (!header->readonly) header->readonly = 1;
+# endif
+    if (mprotect(header, len, PROT_READ))
 	Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
-			 buf, len, errno);
+			 header, len, errno);
 }
 
 void
 Perl_sv_buf_to_rw(pTHX_ SV *sv)
 {
-    char * const buf = SvPVX(sv)-sizeof(IV);
-    const size_t len = (size_t)*(IV *)buf;
+    struct perl_memory_debug_header * const header =
+	(struct perl_memory_debug_header *)(SvPVX(sv)-sTHX);
+    const MEM_SIZE len = header->size;
     PERL_ARGS_ASSERT_SV_BUF_TO_RW;
-    if (mprotect(buf, len, PROT_READ|PROT_WRITE))
+    if (mprotect(header, len, PROT_READ|PROT_WRITE))
 	Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
-			 buf, len, errno);
+			 header, len, errno);
+# ifdef PERL_TRACK_MEMPOOL
+    header->readonly = 0;
+# endif
 }
 
 #else
@@ -4577,7 +4589,7 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
     STRLEN cur = SvCUR(sstr);
     STRLEN len = SvLEN(sstr);
     char *new_pv;
-#ifdef PERL_DEBUG_READONLY_COW
+#if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_NEW_COPY_ON_WRITE)
     const bool already = cBOOL(SvIsCOW(sstr));
 #endif
 
diff --git a/t/op/threads.t b/t/op/threads.t
index 61889a9..6fb2410 100644
--- a/t/op/threads.t
+++ b/t/op/threads.t
@@ -135,7 +135,7 @@ EOI
 #
 # run-time usage of newCONSTSUB (as done by the IO boot code) wasn't
 # thread-safe - got occasional coredumps or malloc corruption
-watchdog(60, "process");
+watchdog(180, "process");
 {
     local $SIG{__WARN__} = sub {};   # Ignore any thread creation failure warnings
     my @t;
diff --git a/t/re/uniprops.t b/t/re/uniprops.t
index 19f011b..927f8a7 100644
--- a/t/re/uniprops.t
+++ b/t/re/uniprops.t
@@ -8,7 +8,6 @@ no warnings 'once';
 # It is skipped by default under PERL_DEBUG_READONLY_COW, but you can run
 # it directly via:  cd t; ./perl ../lib/unicore/TestProp.pl
 
-@INC = '../lib';
 require Config;
 if ($Config::Config{ccflags} =~ /(?:^|\s)-DPERL_DEBUG_READONLY_COW\b/) {
     print "1..0 # Skip PERL_DEBUG_READONLY_COW\n";
diff --git a/util.c b/util.c
index 84efc10..4427750 100644
--- a/util.c
+++ b/util.c
@@ -71,6 +71,40 @@ int putenv(char *);
 #  define ALWAYS_NEED_THX
 #endif
 
+#if defined(PERL_TRACK_MEMPOOL) && defined(PERL_DEBUG_READONLY_COW)
+static void
+S_maybe_protect_rw(pTHX_ struct perl_memory_debug_header *header)
+{
+    if (header->readonly
+     && mprotect(header, header->size, PROT_READ|PROT_WRITE))
+	Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
+			 header, header->size, errno);
+}
+
+static void
+S_maybe_protect_ro(pTHX_ struct perl_memory_debug_header *header)
+{
+    if (header->readonly
+     && mprotect(header, header->size, PROT_READ))
+	Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
+			 header, header->size, errno);
+}
+# define maybe_protect_rw(foo) S_maybe_protect_rw(aTHX_ foo)
+# define maybe_protect_ro(foo) S_maybe_protect_ro(aTHX_ foo)
+#else
+# define maybe_protect_rw(foo) NOOP
+# define maybe_protect_ro(foo) NOOP
+#endif
+
+#if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
+ /* Use memory_debug_header */
+# define USE_MDH
+# if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \
+   || defined(PERL_DEBUG_READONLY_COW)
+#  define MDH_HAS_SIZE
+# endif
+#endif
+
 /* paranoid version of system's malloc() */
 
 Malloc_t
@@ -80,16 +114,14 @@ Perl_safesysmalloc(MEM_SIZE size)
     dTHX;
 #endif
     Malloc_t ptr;
-#ifdef PERL_TRACK_MEMPOOL
     size += sTHX;
-#endif
 #ifdef DEBUGGING
     if ((SSize_t)size < 0)
 	Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
 #endif
     if (!size) size = 1;	/* malloc(0) is NASTY on our system */
 #ifdef PERL_DEBUG_READONLY_COW
-    if ((ptr = mmap(0, size+sizeof(IV), PROT_READ|PROT_WRITE,
+    if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
 		    MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
 	perror("mmap failed");
 	abort();
@@ -99,7 +131,7 @@ Perl_safesysmalloc(MEM_SIZE size)
 #endif
     PERL_ALLOC_CHECK(ptr);
     if (ptr != NULL) {
-#ifdef PERL_TRACK_MEMPOOL
+#ifdef USE_MDH
 	struct perl_memory_debug_header *const header
 	    = (struct perl_memory_debug_header *)ptr;
 #endif
@@ -114,16 +146,17 @@ Perl_safesysmalloc(MEM_SIZE size)
 	header->prev = &PL_memory_debug_header;
 	header->next = PL_memory_debug_header.next;
 	PL_memory_debug_header.next = header;
+	maybe_protect_rw(header->next);
 	header->next->prev = header;
-#  ifdef PERL_POISON
-	header->size = size;
+	maybe_protect_ro(header->next);
+#  ifdef PERL_DEBUG_READONLY_COW
+	header->readonly = 0;
 #  endif
-        ptr = (Malloc_t)((char*)ptr+sTHX);
 #endif
-#ifdef PERL_DEBUG_READONLY_COW
-	*(IV *)ptr = (IV)size;
-	ptr = (Malloc_t)((char*)ptr+sizeof(IV));
+#ifdef MDH_HAS_SIZE
+	header->size = size;
 #endif
+        ptr = (Malloc_t)((char*)ptr+sTHX);
 	DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld \
bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));  return ptr;
 }
@@ -150,8 +183,9 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 #endif
     Malloc_t ptr;
 #ifdef PERL_DEBUG_READONLY_COW
-    MEM_SIZE oldsize =
-	where ? (MEM_SIZE)*(IV *)((char *)where - sizeof(IV)) : 0;
+    const MEM_SIZE oldsize = where
+	? ((struct perl_memory_debug_header *)((char *)where - sTHX))->size
+	: 0;
 #endif
 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
     Malloc_t PerlMem_realloc();
@@ -164,16 +198,14 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 
     if (!where)
 	return safesysmalloc(size);
-#ifdef PERL_DEBUG_READONLY_COW
-    where = (Malloc_t)((char*)where-sizeof(IV));
-#endif
-#ifdef PERL_TRACK_MEMPOOL
+#ifdef USE_MDH
     where = (Malloc_t)((char*)where-sTHX);
     size += sTHX;
     {
 	struct perl_memory_debug_header *const header
 	    = (struct perl_memory_debug_header *)where;
 
+# ifdef PERL_TRACK_MEMPOOL
 	if (header->interpreter != aTHX) {
 	    Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
 				 header->interpreter, aTHX);
@@ -186,8 +218,11 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 	    char *start_of_freed = ((char *)where) + size;
 	    PoisonFree(start_of_freed, freed_up, char);
 	}
-	header->size = size;
 #  endif
+# endif
+# ifdef MDH_HAS_SIZE
+	header->size = size;
+# endif
     }
 #endif
 #ifdef DEBUGGING
@@ -195,13 +230,13 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 	Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
 #endif
 #ifdef PERL_DEBUG_READONLY_COW
-    if ((ptr = mmap(0, size+sizeof(IV), PROT_READ|PROT_WRITE,
+    if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
 		    MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
 	perror("mmap failed");
 	abort();
     }
-    Copy(where,ptr,(oldsize < size ? oldsize : size)+sizeof(IV),char);
-    if (munmap(where, oldsize+sizeof(IV))) {
+    Copy(where,ptr,oldsize < size ? oldsize : size,char);
+    if (munmap(where, oldsize)) {
 	perror("munmap failed");
 	abort();
     }
@@ -213,8 +248,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
     /* MUST do this fixup first, before doing ANYTHING else, as anything else
        might allocate memory/free/move memory, and until we do the fixup, it
        may well be chasing (and writing to) free memory.  */
-#ifdef PERL_TRACK_MEMPOOL
     if (ptr != NULL) {
+#ifdef PERL_TRACK_MEMPOOL
 	struct perl_memory_debug_header *const header
 	    = (struct perl_memory_debug_header *)ptr;
 
@@ -226,18 +261,15 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 	}
 #  endif
 
+	maybe_protect_rw(header->next);
 	header->next->prev = header;
+	maybe_protect_ro(header->next);
+	maybe_protect_rw(header->prev);
 	header->prev->next = header;
-
-        ptr = (Malloc_t)((char*)ptr+sTHX);
-    }
+	maybe_protect_ro(header->prev);
 #endif
-#ifdef PERL_DEBUG_READONLY_COW
-    if (ptr) {
-	*(IV *)ptr = (IV)size;
-	ptr = (Malloc_t)((char *)ptr + sizeof(IV));
+        ptr = (Malloc_t)((char*)ptr+sTHX);
     }
-#endif
 
     /* In particular, must do that fixup above before logging anything via
      *printf(), as it can reallocate memory, which can cause SEGVs.  */
@@ -274,16 +306,16 @@ Perl_safesysfree(Malloc_t where)
 #endif
     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) \
free\n",PTR2UV(where),(long)PL_an++));  if (where) {
-#ifdef PERL_DEBUG_READONLY_COW
-	MEM_SIZE size = (MEM_SIZE)*(IV *)((char *)where - sizeof(IV));
-	where = (Malloc_t)((char *)where - sizeof(IV));
-#endif
-#ifdef PERL_TRACK_MEMPOOL
+#ifdef USE_MDH
         where = (Malloc_t)((char*)where-sTHX);
 	{
 	    struct perl_memory_debug_header *const header
 		= (struct perl_memory_debug_header *)where;
 
+# ifdef MDH_HAS_SIZE
+	    const MEM_SIZE size = header->size;
+# endif
+# ifdef PERL_TRACK_MEMPOOL
 	    if (header->interpreter != aTHX) {
 		Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
 				     header->interpreter, aTHX);
@@ -300,21 +332,28 @@ Perl_safesysfree(Malloc_t where)
 				     header->prev->next);
 	    }
 	    /* Unlink us from the chain.  */
+	    maybe_protect_rw(header->next);
 	    header->next->prev = header->prev;
+	    maybe_protect_ro(header->next);
+	    maybe_protect_rw(header->prev);
 	    header->prev->next = header->next;
+	    maybe_protect_ro(header->prev);
+	    maybe_protect_rw(header);
 #  ifdef PERL_POISON
-	    PoisonNew(where, header->size, char);
+	    PoisonNew(where, size, char);
 #  endif
 	    /* Trigger the duplicate free warning.  */
 	    header->next = NULL;
+# endif
+# ifdef PERL_DEBUG_READONLY_COW
+	    if (munmap(where, size)) {
+		perror("munmap failed");
+		abort();
+	    }	
+# endif
 	}
 #endif
-#ifdef PERL_DEBUG_READONLY_COW
-	if (munmap(where, size+sizeof(IV))) {
-	    perror("munmap failed");
-	    abort();
-	}	
-#else
+#ifndef PERL_DEBUG_READONLY_COW
 	PerlMem_free(where);
 #endif
     }
@@ -325,26 +364,23 @@ Perl_safesysfree(Malloc_t where)
 Malloc_t
 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 {
-#ifdef PERL_DEBUG_READONLY_COW
-    return Perl_safesysmalloc(count*size);
-#else
 #ifdef ALWAYS_NEED_THX
     dTHX;
 #endif
     Malloc_t ptr;
-#if defined(PERL_TRACK_MEMPOOL) || defined(DEBUGGING)
+#if defined(USE_MDH) || defined(DEBUGGING)
     MEM_SIZE total_size = 0;
 #endif
 
     /* Even though calloc() for zero bytes is strange, be robust. */
     if (size && (count <= MEM_SIZE_MAX / size)) {
-#if defined(PERL_TRACK_MEMPOOL) || defined(DEBUGGING)
+#if defined(USE_MDH) || defined(DEBUGGING)
 	total_size = size * count;
 #endif
     }
     else
 	croak_memory_wrap();
-#ifdef PERL_TRACK_MEMPOOL
+#ifdef USE_MDH
     if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
 	total_size += sTHX;
     else
@@ -355,7 +391,13 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 	Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
 			     (UV)size, (UV)count);
 #endif
-#ifdef PERL_TRACK_MEMPOOL
+#ifdef PERL_DEBUG_READONLY_COW
+    if ((ptr = mmap(0, total_size ? total_size : 1, PROT_READ|PROT_WRITE,
+		    MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
+	perror("mmap failed");
+	abort();
+    }
+#elif defined(PERL_TRACK_MEMPOOL)
     /* Have to use malloc() because we've added some space for our tracking
        header.  */
     /* malloc(0) is non-portable. */
@@ -371,19 +413,28 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
     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)total_size));  if (ptr != NULL) \
                {
-#ifdef PERL_TRACK_MEMPOOL
+#ifdef USE_MDH
 	{
 	    struct perl_memory_debug_header *const header
 		= (struct perl_memory_debug_header *)ptr;
 
+#  ifndef PERL_DEBUG_READONLY_COW
 	    memset((void*)ptr, 0, total_size);
+#  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;
+	    maybe_protect_rw(header->next);
 	    header->next->prev = header;
-#  ifdef PERL_POISON
+	    maybe_protect_ro(header->next);
+#    ifdef PERL_DEBUG_READONLY_COW
+	    header->readonly = 0;
+#    endif
+#  endif
+#  ifdef MDH_HAS_SIZE
 	    header->size = total_size;
 #  endif
 	    ptr = (Malloc_t)((char*)ptr+sTHX);
@@ -399,7 +450,6 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 	    return NULL;
 	croak_no_mem();
     }
-#endif /* PERL_DEBUG_READONLY_COW */
 }
 
 /* These must be defined when not using Perl's malloc for binary

--
Perl5 Master Repository


[prev in list] [next in list] [prev in thread] [next in thread] 

Configure | About | News | Add a list | Sponsored by KoreLogic