From: Nicholas Clark Date: Mon, 2 Apr 2007 19:03:55 +0000 (+0000) Subject: Add a new compile option PERL_DEBUG_READONLY_OPS which marks the optree X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f1fac472816f68ec1eac2f84892d78b65a4598fb;p=p5sagit%2Fp5-mst-13.2.git Add a new compile option PERL_DEBUG_READONLY_OPS which marks the optree as read only (or as much of it as it practical). This makes it trivial to detect buggy code that is modifying the optree at runtime. p4raw-id: //depot/perl@30829 --- diff --git a/embed.fnc b/embed.fnc index a8458dd..695adfb 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1222,6 +1222,12 @@ s |void |process_special_blocks |NN const char *const fullname\ #if defined(PL_OP_SLAB_ALLOC) Apa |void* |Slab_Alloc |int m|size_t sz Ap |void |Slab_Free |NN void *op +# if defined(PERL_DEBUG_READONLY_OPS) +poxM |void |pending_Slabs_to_ro +# if defined(PERL_IN_OP_C) +s |void |Slab_to_rw |NN void *op +# endif +# endif #endif #if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT) diff --git a/embed.h b/embed.h index 9228e7b..0c52f84 100644 --- a/embed.h +++ b/embed.h @@ -1217,6 +1217,13 @@ #if defined(PL_OP_SLAB_ALLOC) #define Slab_Alloc Perl_Slab_Alloc #define Slab_Free Perl_Slab_Free +# if defined(PERL_DEBUG_READONLY_OPS) +# if defined(PERL_IN_OP_C) +#ifdef PERL_CORE +#define Slab_to_rw S_Slab_to_rw +#endif +# endif +# endif #endif #if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE @@ -3446,6 +3453,15 @@ #if defined(PL_OP_SLAB_ALLOC) #define Slab_Alloc(a,b) Perl_Slab_Alloc(aTHX_ a,b) #define Slab_Free(a) Perl_Slab_Free(aTHX_ a) +# if defined(PERL_DEBUG_READONLY_OPS) +#ifdef PERL_CORE +#endif +# if defined(PERL_IN_OP_C) +#ifdef PERL_CORE +#define Slab_to_rw(a) S_Slab_to_rw(aTHX_ a) +#endif +# endif +# endif #endif #if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE diff --git a/embedvar.h b/embedvar.h index 0898cf6..bc1d3aa 100644 --- a/embedvar.h +++ b/embedvar.h @@ -324,6 +324,8 @@ #define PL_sig_pending (vTHX->Isig_pending) #define PL_sighandlerp (vTHX->Isighandlerp) #define PL_signals (vTHX->Isignals) +#define PL_slab_count (vTHX->Islab_count) +#define PL_slabs (vTHX->Islabs) #define PL_sort_RealCmp (vTHX->Isort_RealCmp) #define PL_splitstr (vTHX->Isplitstr) #define PL_srand_called (vTHX->Isrand_called) @@ -590,6 +592,8 @@ #define PL_Isig_pending PL_sig_pending #define PL_Isighandlerp PL_sighandlerp #define PL_Isignals PL_signals +#define PL_Islab_count PL_slab_count +#define PL_Islabs PL_slabs #define PL_Isort_RealCmp PL_sort_RealCmp #define PL_Isplitstr PL_splitstr #define PL_Isrand_called PL_srand_called diff --git a/intrpvar.h b/intrpvar.h index a8d8131..4d19b98 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -527,6 +527,11 @@ PERLVARI(Iutf8cache, I8, -1) /* Is the utf8 caching code enabled? */ PERLVARI(Iutf8cache, I8, 1) /* Is the utf8 caching code enabled? */ #endif +#ifdef PERL_DEBUG_READONLY_OPS +PERLVARI(Islabs, I32**, NULL) /* Array of slabs that have been allocated */ +PERLVARI(Islab_count, U32, 0) /* Size of the array */ +#endif + /* New variables must be added to the very end, before this comment, * for binary compatibility (the offsets of the old members must not change). * (Don't forget to add your variable also to perl_clone()!) diff --git a/op.c b/op.c index f05be0b..49a3313 100644 --- a/op.c +++ b/op.c @@ -104,6 +104,11 @@ recursive, but it's recursive on basic blocks, not on tree nodes. #if defined(PL_OP_SLAB_ALLOC) +#ifdef PERL_DEBUG_READONLY_OPS +# define PERL_SLAB_SIZE 4096 +# include +#endif + #ifndef PERL_SLAB_SIZE #define PERL_SLAB_SIZE 2048 #endif @@ -119,7 +124,22 @@ Perl_Slab_Alloc(pTHX_ int m, size_t sz) */ sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *); if ((PL_OpSpace -= sz) < 0) { +#ifdef PERL_DEBUG_READONLY_OPS + /* We need to allocate chunk by chunk so that we can control the VM + mapping */ + PL_OpPtr = mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE, + MAP_ANON|MAP_PRIVATE, -1, 0); + + DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n", + (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), + PL_OpPtr)); + if(PL_OpPtr == MAP_FAILED) { + perror("mmap failed"); + abort(); + } +#else PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*)); +#endif if (!PL_OpPtr) { return NULL; } @@ -135,6 +155,14 @@ Perl_Slab_Alloc(pTHX_ int m, size_t sz) means that at run time access is cache friendly upward */ PL_OpPtr += PERL_SLAB_SIZE; + +#ifdef PERL_DEBUG_READONLY_OPS + /* We remember this slab. */ + /* This implementation isn't efficient, but it is simple. */ + PL_slabs = realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1)); + PL_slabs[PL_slab_count++] = PL_OpSlab; + DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab)); +#endif } assert( PL_OpSpace >= 0 ); /* Move the allocation pointer down */ @@ -147,6 +175,51 @@ Perl_Slab_Alloc(pTHX_ int m, size_t sz) return (void *)(PL_OpPtr + 1); } +#ifdef PERL_DEBUG_READONLY_OPS +void +Perl_pending_Slabs_to_ro(pTHX) { + /* Turn all the allocated op slabs read only. */ + U32 count = PL_slab_count; + I32 **const slabs = PL_slabs; + + /* Reset the array of pending OP slabs, as we're about to turn this lot + read only. Also, do it ahead of the loop in case the warn triggers, + and a warn handler has an eval */ + + free(PL_slabs); + PL_slabs = NULL; + PL_slab_count = 0; + + /* Force a new slab for any further allocation. */ + PL_OpSpace = 0; + + while (count--) { + const void *start = slabs[count]; + const size_t size = PERL_SLAB_SIZE* sizeof(I32*); + if(mprotect(start, size, PROT_READ)) { + Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", + start, (unsigned long) size, errno); + } + } +} + +STATIC void +S_Slab_to_rw(pTHX_ void *op) +{ + I32 * const * const ptr = (I32 **) op; + I32 * const slab = ptr[-1]; + assert( ptr-1 > (I32 **) slab ); + assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) ); + assert( *slab > 0 ); + if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) { + Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", + slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno); + } +} +#else +# define Slab_to_rw(op) +#endif + void Perl_Slab_Free(pTHX_ void *op) { @@ -155,12 +228,44 @@ Perl_Slab_Free(pTHX_ void *op) assert( ptr-1 > (I32 **) slab ); assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) ); assert( *slab > 0 ); + Slab_to_rw(op); if (--(*slab) == 0) { # ifdef NETWARE # define PerlMemShared PerlMem # endif +#ifdef PERL_DEBUG_READONLY_OPS + /* Need to remove this slab from our list of slabs */ + { + U32 count = PL_slab_count; + + while (count--) { + if (PL_slabs[count] == slab) { + /* Found it. Move the entry at the end to overwrite it. */ + DEBUG_m(PerlIO_printf(Perl_debug_log, + "Deallocate %p by moving %p from %lu to %lu\n", + PL_OpSlab, + PL_slabs[PL_slab_count - 1], + PL_slab_count, count)); + PL_slabs[count] = PL_slabs[--PL_slab_count]; + /* Could realloc smaller at this point, but probably not + worth it. */ + goto gotcha; + } + + } + Perl_croak(aTHX_ + "panic: Couldn't find slab at %p (%lu allocated)", + slab, (unsigned long) PL_slabs); + gotcha: + if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) { + perror("munmap failed"); + abort(); + } + } +#else PerlMemShared_free(slab); +#endif if (slab == PL_OpSlab) { PL_OpSpace = 0; } @@ -318,6 +423,9 @@ Perl_op_free(pTHX_ OP *o) case OP_LEAVEWRITE: { PADOFFSET refcnt; +#ifdef PERL_DEBUG_READONLY_OPS + Slab_to_rw(o); +#endif OP_REFCNT_LOCK; refcnt = OpREFCNT_dec(o); OP_REFCNT_UNLOCK; diff --git a/perl.c b/perl.c index e18d5cc..b983e7d 100644 --- a/perl.c +++ b/perl.c @@ -1240,6 +1240,11 @@ perl_destruct(pTHXx) #endif PL_sv_count = 0; +#ifdef PERL_DEBUG_READONLY_OPS + free(PL_slabs); + PL_slabs = NULL; + PL_slab_count = 0; +#endif #if defined(PERLIO_LAYERS) /* No more IO - including error messages ! */ @@ -2369,6 +2374,9 @@ perl_run(pTHXx) return ret; } +#ifdef PERL_DEBUG_READONLY_OPS +# include +#endif STATIC void S_run_body(pTHX_ I32 oldscope) @@ -2406,6 +2414,9 @@ S_run_body(pTHX_ I32 oldscope) sv_setiv(PL_DBsingle, 1); if (PL_initav) call_list(oldscope, PL_initav); +#ifdef PERL_DEBUG_READONLY_OPS + Perl_pending_Slabs_to_ro(aTHX); +#endif } /* do it */ diff --git a/perlapi.h b/perlapi.h index 38ebafb..59bb04b 100644 --- a/perlapi.h +++ b/perlapi.h @@ -526,6 +526,10 @@ END_EXTERN_C #define PL_sighandlerp (*Perl_Isighandlerp_ptr(aTHX)) #undef PL_signals #define PL_signals (*Perl_Isignals_ptr(aTHX)) +#undef PL_slab_count +#define PL_slab_count (*Perl_Islab_count_ptr(aTHX)) +#undef PL_slabs +#define PL_slabs (*Perl_Islabs_ptr(aTHX)) #undef PL_sort_RealCmp #define PL_sort_RealCmp (*Perl_Isort_RealCmp_ptr(aTHX)) #undef PL_splitstr diff --git a/pod/perlhack.pod b/pod/perlhack.pod index b176b83..21968d7 100644 --- a/pod/perlhack.pod +++ b/pod/perlhack.pod @@ -3395,8 +3395,47 @@ If you see in a debugger a memory area mysteriously full of 0xABABABAB or 0xEFEFEFEF, you may be seeing the effect of the Poison() macros, see L. +=item * + +Under ithreads the optree is read only. If you want to enforce this, to check +for write accesses from buggy code, compile with C<-DPL_OP_SLAB_ALLOC> to +enable the OP slab allocator and C<-DPERL_DEBUG_READONLY_OPS> to enable code +that allocates op memory via C, and sets it read-only at run time. +Any write access to an op results in a C and abort. + +This code is intended for development only, and may not be portable even to +all Unix variants. Also, it is an 80% solution, in that it isn't able to make +all ops read only. Specifically it + +=over + +=item 1 + +Only sets read-only on all slabs of ops at C time, hence ops allocated +later via C or C will be re-write + +=item 2 + +Turns an entire slab of ops read-write if the refcount of any op in the slab +needs to be decreased. + +=item 3 + +Turns an entire slab of ops read-write if any op from the slab is freed. + =back +It's not possible to turn the slabs to read-only after an action requiring +read-write access, as either can happen during op tree building time, so +there may still be legitimate write access. + +However, as an 80% solution it is still effective, as currently it catches +a write access during the generation of F, which means that we +can't yet build F with this enabled. + +=back + + =head1 CONCLUSION We've had a brief look around the Perl source, how to maintain quality diff --git a/proto.h b/proto.h index 811730a..24a18af 100644 --- a/proto.h +++ b/proto.h @@ -3322,6 +3322,14 @@ PERL_CALLCONV void* Perl_Slab_Alloc(pTHX_ int m, size_t sz) PERL_CALLCONV void Perl_Slab_Free(pTHX_ void *op) __attribute__nonnull__(pTHX_1); +# if defined(PERL_DEBUG_READONLY_OPS) +PERL_CALLCONV void Perl_pending_Slabs_to_ro(pTHX); +# if defined(PERL_IN_OP_C) +STATIC void S_Slab_to_rw(pTHX_ void *op) + __attribute__nonnull__(pTHX_1); + +# endif +# endif #endif #if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)