PERL_DEBUG_READONLY_COW

Make perls compiled with -Accflags=-DPERL_DEBUG_READONLY_COW to turn
COW buffer violations into crashes.

We do this using mmap to allocate memory and then mprotect to mark
memory as read-only when buffers are shared.

We have to do this at the safesysmalloc level, because some code does
SvPV_set with buffers it allocates on its own via safemalloc().

Unfortunately this means many things are allocated using mmap that
will never be marked read-only, slowing things down considerably, but
I see no other way.

Because munmap and mprotect need to know the length, we use the
existing sTHX/perl_memory_debug_header mechanism used already by
PERL_TRACK_MEMPOOL and store the size there (as PERL_POISON already
does when PERL_TRACK_MEMPOOL is enabled).  perl_memory_debug_header is
a struct positioned at the beginning of every allocated buffer, for
tracking things.

diff --git a/embed.fnc b/embed.fnc
index dc6beb7..a4d9dab 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1315,6 +1315,10 @@ sd       |void   |sv_add_arena   |NN char *const ptr|const U32 size \
 #endif
 Apd    |int    |sv_backoff     |NN SV *const sv
 Apd    |SV*    |sv_bless       |NN SV *const sv|NN HV *const stash
+#if defined(PERL_DEBUG_READONLY_COW)
+p      |void   |sv_buf_to_ro   |NN SV *sv
+p      |void   |sv_buf_to_rw   |NN SV *sv
+#endif
 Afpd   |void   |sv_catpvf      |NN SV *const sv|NN const char *const pat|...
 Apd    |void   |sv_vcatpvf     |NN SV *const sv|NN const char *const pat \
                                |NULLOK va_list *const args

diff --git a/embed.h b/embed.h
index baf1030..be600f9 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1364,6 +1364,10 @@
 #define strip_return(a)                S_strip_return(aTHX_ a)
 #    endif
 #  endif
+#  if defined(PERL_DEBUG_READONLY_COW)
+#define sv_buf_to_ro(a)                Perl_sv_buf_to_ro(aTHX_ a)
+#define sv_buf_to_rw(a)                Perl_sv_buf_to_rw(aTHX_ a)
+#  endif
 #  if defined(PERL_IN_AV_C)
 #define get_aux_mg(a)          S_get_aux_mg(aTHX_ a)
 #  endif

diff --git a/op.c b/op.c
index fc23314..bb58bf6 100644 (file)
--- a/op.c
+++ b/op.c
@@ -10857,6 +10857,9 @@ Perl_ck_svconst(pTHX_ OP *o)
     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
        SvIsCOW_on(sv);
        CowREFCNT(sv) = 0;
+# ifdef PERL_DEBUG_READONLY_COW
+       sv_buf_to_ro(sv);
+# endif
     }
 #endif
     SvREADONLY_on(sv);

diff --git a/perl.h b/perl.h
index d00c64b..ee167db 100644 (file)
--- 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
 
@@ -4048,7 +4071,7 @@ struct perl_memory_debug_header {
 #ifdef MYMALLOC
 #  define Perl_safesysmalloc_size(where)       Perl_malloced_size(where)
 #else
-#  ifdef HAS_MALLOC_SIZE
+#  if defined(HAS_MALLOC_SIZE) && !defined(PERL_DEBUG_READONLY_COW)
 #    ifdef PERL_TRACK_MEMPOOL
 #      define Perl_safesysmalloc_size(where)                   \
            (malloc_size(((char *)(where)) - sTHX) - sTHX)

diff --git a/proto.h b/proto.h
index 2007ef7..94d057c 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -5501,6 +5501,18 @@ STATIC void      S_strip_return(pTHX_ SV *sv)
 
 #  endif
 #endif
+#if defined(PERL_DEBUG_READONLY_COW)
+PERL_CALLCONV void     Perl_sv_buf_to_ro(pTHX_ SV *sv)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_BUF_TO_RO  \
+       assert(sv)
+
+PERL_CALLCONV void     Perl_sv_buf_to_rw(pTHX_ SV *sv)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_BUF_TO_RW  \
+       assert(sv)
+
+#endif
 #if defined(PERL_DEBUG_READONLY_OPS)
 PERL_CALLCONV PADOFFSET        Perl_op_refcnt_dec(pTHX_ OP *o)
                        __attribute__nonnull__(pTHX_1);

diff --git a/sv.c b/sv.c
index 630544f..7f05c02 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -4033,6 +4033,48 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
 # define GE_COWBUF_THRESHOLD(len)      1
 #endif
 
+#ifdef PERL_DEBUG_READONLY_COW
+# include <sys/mman.h>
+
+# ifndef sTHX
+#  define sTHX 0
+# endif
+
+void
+Perl_sv_buf_to_ro(pTHX_ SV *sv)
+{
+    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;
+# 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",
+                        header, len, errno);
+}
+
+void
+Perl_sv_buf_to_rw(pTHX_ SV *sv)
+{
+    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(header, len, PROT_READ|PROT_WRITE))
+       Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
+                        header, len, errno);
+# ifdef PERL_TRACK_MEMPOOL
+    header->readonly = 0;
+# endif
+}
+
+#else
+# define sv_buf_to_ro(sv)      NOOP
+# define sv_buf_to_rw(sv)      NOOP
+#endif
+
 void
 Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
 {
@@ -4435,9 +4477,13 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
                     SV_COW_NEXT_SV_SET(sstr, dstr);
 # else
+                   if (sflags & SVf_IsCOW) {
+                       sv_buf_to_rw(sstr);
+                   }
                    CowREFCNT(sstr)++;
 # endif
                     SvPV_set(dstr, SvPVX_mutable(sstr));
+                    sv_buf_to_ro(sstr);
             } else
 #endif
             {
@@ -4531,6 +4577,9 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
     STRLEN cur = SvCUR(sstr);
     STRLEN len = SvLEN(sstr);
     char *new_pv;
+#if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_NEW_COPY_ON_WRITE)
+    const bool already = cBOOL(SvIsCOW(sstr));
+#endif
 
     PERL_ARGS_ASSERT_SV_SETSV_COW;
 
@@ -4591,9 +4640,13 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
 # ifdef PERL_OLD_COPY_ON_WRITE
     SV_COW_NEXT_SV_SET(sstr, dstr);
 # else
+#  ifdef PERL_DEBUG_READONLY_COW
+    if (already) sv_buf_to_rw(sstr);
+#  endif
     CowREFCNT(sstr)++; 
 # endif
     new_pv = SvPVX_mutable(sstr);
+    sv_buf_to_ro(sstr);
 
   common_exit:
     SvPV_set(dstr, new_pv);
@@ -4868,6 +4921,7 @@ S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after)
                in the loop.)
                Hence other SV is no longer copy on write either.  */
             SvIsCOW_off(after);
+            sv_buf_to_rw(after);
         } else {
             /* We need to follow the pointers around the loop.  */
             SV *next;
@@ -4932,7 +4986,7 @@ S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
 # ifdef PERL_NEW_COPY_ON_WRITE
        if (len && CowREFCNT(sv) == 0)
            /* We own the buffer ourselves. */
-           NOOP;
+           sv_buf_to_rw(sv);
        else
 # endif
        {
@@ -4940,7 +4994,11 @@ S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
 # ifdef PERL_NEW_COPY_ON_WRITE
            /* Must do this first, since the macro uses SvPVX. */
-           if (len) CowREFCNT(sv)--;
+           if (len) {
+               sv_buf_to_rw(sv);
+               CowREFCNT(sv)--;
+               sv_buf_to_ro(sv);
+           }
 # endif
             SvPV_set(sv, NULL);
             SvLEN_set(sv, 0);
@@ -6421,7 +6479,9 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
                        sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
 # else
                        if (CowREFCNT(sv)) {
+                           sv_buf_to_rw(sv);
                            CowREFCNT(sv)--;
+                           sv_buf_to_ro(sv);
                            SvLEN_set(sv, 0);
                        }
 # endif

diff --git a/util.c b/util.c
index f308e93..938b037 100644 (file)
--- a/util.c
+++ b/util.c
@@ -51,6 +51,10 @@ int putenv(char *);
 # endif
 #endif
 
+#ifdef PERL_DEBUG_READONLY_COW
+# include <sys/mman.h>
+#endif
+
 #define FLUSH
 
 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
@@ -67,6 +71,31 @@ 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
+
 /* paranoid version of system's malloc() */
 
 Malloc_t
@@ -76,17 +105,24 @@ 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
-    ptr = (Malloc_t)PerlMem_malloc(size?size:1);       /* malloc(0) is NASTY on our system */
+    if (!size) size = 1;       /* malloc(0) is NASTY on our system */
+#ifdef PERL_DEBUG_READONLY_COW
+    if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
+                   MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
+       perror("mmap failed");
+       abort();
+    }
+#else
+    ptr = (Malloc_t)PerlMem_malloc(size?size:1);
+#endif
     PERL_ALLOC_CHECK(ptr);
     if (ptr != NULL) {
-#ifdef PERL_TRACK_MEMPOOL
+#if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
        struct perl_memory_debug_header *const header
            = (struct perl_memory_debug_header *)ptr;
 #endif
@@ -101,12 +137,18 @@ 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
+#if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \
+  || defined(PERL_DEBUG_READONLY_COW)
+       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;
 }
@@ -132,6 +174,11 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
     dTHX;
 #endif
     Malloc_t ptr;
+#ifdef PERL_DEBUG_READONLY_COW
+    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();
 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
@@ -143,13 +190,14 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 
     if (!where)
        return safesysmalloc(size);
-#ifdef PERL_TRACK_MEMPOOL
+#if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
     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);
@@ -162,22 +210,38 @@ 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
+# if defined(PERL_POISON) || defined(PERL_DEBUG_READONLY_COW)
+       header->size = size;
+# endif
     }
 #endif
 #ifdef DEBUGGING
     if ((SSize_t)size < 0)
        Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
 #endif
+#ifdef PERL_DEBUG_READONLY_COW
+    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,char);
+    if (munmap(where, oldsize)) {
+       perror("munmap failed");
+       abort();
+    }
+#else
     ptr = (Malloc_t)PerlMem_realloc(where,size);
+#endif
     PERL_ALLOC_CHECK(ptr);
 
     /* 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;
 
@@ -189,12 +253,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;
-
+       maybe_protect_ro(header->prev);
+#endif
         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.  */
@@ -231,12 +298,17 @@ 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_TRACK_MEMPOOL
+#if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
         where = (Malloc_t)((char*)where-sTHX);
        {
            struct perl_memory_debug_header *const header
                = (struct perl_memory_debug_header *)where;
 
+# if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \
+   || defined(PERL_DEBUG_READONLY_COW)
+           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);
@@ -253,16 +325,30 @@ 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
+#ifndef PERL_DEBUG_READONLY_COW
        PerlMem_free(where);
+#endif
     }
 }
 
@@ -275,19 +361,21 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
     dTHX;
 #endif
     Malloc_t ptr;
-#if defined(PERL_TRACK_MEMPOOL) || defined(DEBUGGING)
+#if defined(PERL_TRACK_MEMPOOL) || defined(DEBUGGING) \
+ || defined(PERL_DEBUG_READONLY_COW)
     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(PERL_TRACK_MEMPOOL) || defined(DEBUGGING) \
+ || defined(PERL_DEBUG_READONLY_COW)
        total_size = size * count;
 #endif
     }
     else
        croak_memory_wrap();
-#ifdef PERL_TRACK_MEMPOOL
+#if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
     if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
        total_size += sTHX;
     else
@@ -298,7 +386,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. */
@@ -314,19 +408,29 @@ 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
+#if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
        {
            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
+#  if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \
+    || defined(PERL_DEBUG_READONLY_COW)
            header->size = total_size;
 #  endif
            ptr = (Malloc_t)((char*)ptr+sTHX);