This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add a new compile option PERL_DEBUG_READONLY_OPS which marks the optree
authorNicholas Clark <nick@ccl4.org>
Mon, 2 Apr 2007 19:03:55 +0000 (19:03 +0000)
committerNicholas Clark <nick@ccl4.org>
Mon, 2 Apr 2007 19:03:55 +0000 (19:03 +0000)
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

embed.fnc
embed.h
embedvar.h
intrpvar.h
op.c
perl.c
perlapi.h
pod/perlhack.pod
proto.h

index a8458dd..695adfb 100644 (file)
--- 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 (file)
--- a/embed.h
+++ b/embed.h
 #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
 #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
index 0898cf6..bc1d3aa 100644 (file)
 #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)
 #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
index a8d8131..4d19b98 100644 (file)
@@ -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 (file)
--- 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 <sys/mman.h>
+#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 (file)
--- 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 <sys/mman.h>
+#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 */
index 38ebafb..59bb04b 100644 (file)
--- 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
index b176b83..21968d7 100644 (file)
@@ -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<perlclib>.
 
+=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<mmap>, and sets it read-only at run time.
+Any write access to an op results in a C<SIGBUS> 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<CHECK> time, hence ops allocated
+later via C<require> or C<eval> 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<Config.pm>, which means that we
+can't yet build F<perl> 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 (file)
--- 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)