develooper Front page | perl.perl5.porters | Postings from April 2007

Re: pmdynflags and thread safety

Thread Previous | Thread Next
From:
Nicholas Clark
Date:
April 1, 2007 03:48
Subject:
Re: pmdynflags and thread safety
Message ID:
20070401104816.GP5748@plum.flirble.org
On Sun, Apr 01, 2007 at 01:24:19AM +0100, Dave Mitchell wrote:
> On Sat, Mar 31, 2007 at 11:40:23PM +0100, Nicholas Clark wrote:
> > and yet in pp_match I see things like
> > 
> > 	PL_curpm = pm;
> > 	if (dynpm->op_pmflags & PMf_ONCE)
> > 	    dynpm->op_pmdynflags |= PMdf_USED;
> > 
> > 
> > 
> > This is modifying the optree, isn't it?
> 
> Um, yes.
> 
> > And that is bad and wrong, isn't it?
> 
> Um, yes:

OK. It occurred to me that with the OP slab allocator, we could make OPs
read only.

Actually, it seems that only an 80% solution is possible:

1: at main program start turn all ops read only (so ops in subsequent requires
   and evals will be missed)
2: Decreasing an ops refcount requires write access, and you can't easily know
   if this block was read only, so just turn it read write
3: Likewise deleting an op from a slap requires write access, and you can't
   easily know whether it was read only

However, 80% is good enough. We catch our first miscreant before perl is
even built:

Starting program: /home/nick/p4perl/perl/miniperl -Ilib configpm --heavy=lib/Config_heavy.pl lib/Config.pm

Program received signal SIGBUS, Bus error.
0x0818420a in Perl_pp_regcomp (my_perl=0x82b5000) at pp_ctl.c:149
149                 pm->op_pmflags = pm->op_pmpermflags;        /* reset case sensitivity */

I don't have time to even think about this right now (about to go out) but it
looks like op_pmflags and op_pmdynflags need to be in the pad, or somesuch

Is it worth applying the appended code to the core? It should make it
incredibly fast to find optree violators.

You need to build with -DPL_OP_SLAB_ALLOC -DPERL_DEBUG_READONLY_OPS

Nicholas Clark

==== //depot/perl/intrpvar.h#190 - /home/nick/p4perl/perl/intrpvar.h ====
--- /tmp/tmp.68359.0	Sun Apr  1 11:41:41 2007
+++ /home/nick/p4perl/perl/intrpvar.h	Sun Apr  1 10:34:58 2007
@@ -527,6 +527,11 @@ PERLVARI(Iutf8cache, I8, -1)	/* Is the u
 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()!)
==== //depot/perl/op.c#902 - /home/nick/p4perl/perl/op.c ====
--- /tmp/tmp.68359.1	Sun Apr  1 11:41:41 2007
+++ /home/nick/p4perl/perl/op.c	Sun Apr  1 11:40:18 2007
@@ -104,6 +104,11 @@ recursive, but it's recursive on basic b
 
 #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, -1, 0);
+
+	DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p",
+			      (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
+			      PL_OpPtr));
+	if(!PL_OpPtr) {
+	    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,22 @@ Perl_Slab_Alloc(pTHX_ int m, size_t sz)
     return (void *)(PL_OpPtr + 1);
 }
 
+#ifdef PERL_DEBUG_READONLY_OPS
+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);
+    }
+}
+#endif
+
 void
 Perl_Slab_Free(pTHX_ void *op)
 {
@@ -155,12 +199,44 @@ Perl_Slab_Free(pTHX_ void *op)
     assert( ptr-1 > (I32 **) slab );
     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
     assert( *slab > 0 );
+    S_Slab_to_rw(aTHX_ 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 +394,7 @@ Perl_op_free(pTHX_ OP *o)
 	case OP_LEAVEWRITE:
 	    {
 	    PADOFFSET refcnt;
+	    S_Slab_to_rw(aTHX_ o);
 	    OP_REFCNT_LOCK;
 	    refcnt = OpREFCNT_dec(o);
 	    OP_REFCNT_UNLOCK;
==== //depot/perl/perl.c#795 - /home/nick/p4perl/perl/perl.c ====
--- /tmp/tmp.68359.2	Sun Apr  1 11:41:41 2007
+++ /home/nick/p4perl/perl/perl.c	Sun Apr  1 11:33:43 2007
@@ -2369,6 +2369,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 +2409,23 @@ S_run_body(pTHX_ I32 oldscope)
 	    sv_setiv(PL_DBsingle, 1);
 	if (PL_initav)
 	    call_list(oldscope, PL_initav);
+#ifdef PERL_DEBUG_READONLY_OPS
+	/* Turn all the allocated op slabs read only.  */
+	{
+	    U32 count = PL_slab_count;
+
+	    while (count--) {
+		const void *start = PL_slabs[count];
+		const size_t size = 4096 * sizeof(I32*);
+		if(mprotect(start, size, PROT_READ)) {
+		    Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
+			      start, (unsigned long) size, errno);
+		}
+	    }
+	    /* Force a new slab for any further allocation.  */
+	    PL_OpSpace = 0;
+	}
+#endif
     }
 
     /* do it */

Thread Previous | Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About