# 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)
{
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
{
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;
# 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);
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;
# ifdef PERL_NEW_COPY_ON_WRITE
if (len && CowREFCNT(sv) == 0)
/* We own the buffer ourselves. */
- NOOP;
+ sv_buf_to_rw(sv);
else
# endif
{
/* 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);
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
# endif
#endif
+#ifdef PERL_DEBUG_READONLY_COW
+# include <sys/mman.h>
+#endif
+
#define FLUSH
#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
# 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
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
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;
}
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) */
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);
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;
}
# 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. */
#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);
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
}
}
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
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. */
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);