From b001a0d149ed99df18916796f3a72b2c888b94d8 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Wed, 4 Dec 2013 04:39:14 -0800 Subject: [PATCH] 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. --- embed.fnc | 4 ++ embed.h | 4 ++ op.c | 3 ++ perl.h | 29 +++++++++++-- proto.h | 12 ++++++ sv.c | 64 +++++++++++++++++++++++++++- util.c | 144 +++++++++++++++++++++++++++++++++++++++++++++++++++++--------- 7 files changed, 235 insertions(+), 25 deletions(-) diff --git a/embed.fnc b/embed.fnc index dc6beb7..a4d9dab 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 + +# 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 --- a/util.c +++ b/util.c @@ -51,6 +51,10 @@ int putenv(char *); # endif #endif +#ifdef PERL_DEBUG_READONLY_COW +# include +#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); -- 2.7.4