From: Nicholas Clark <nick@ccl4.org>
Date: Sat, 7 Apr 2007 17:14:11 +0000 (+0000)
Subject: Under PERL_DEBUG_READONLY_OPS don't panic if you can't find the slab
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=fc97af9c8f85fe5d98c1be12130f8f74fe27a7bf;p=p5sagit%2Fp5-mst-13.2.git

Under PERL_DEBUG_READONLY_OPS don't panic if you can't find the slab
being freed. Also, need to set the slab to read/write before
incrementing or decrementing an op's reference count.
With this we can build all extentions, and run test_harness.

p4raw-id: //depot/perl@30867
---

diff --git a/embed.fnc b/embed.fnc
index 99252c2..7e2cc35 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1227,6 +1227,8 @@ Apa	|void*	|Slab_Alloc	|size_t sz
 Ap	|void	|Slab_Free	|NN void *op
 #  if defined(PERL_DEBUG_READONLY_OPS)
 poxM	|void	|pending_Slabs_to_ro
+poxM	|OP *	|op_refcnt_inc	|NULLOK OP *o
+poxM	|PADOFFSET	|op_refcnt_dec	|NN OP *o
 #    if defined(PERL_IN_OP_C)
 s	|void	|Slab_to_rw	|NN void *op
 #    endif
diff --git a/op.c b/op.c
index 58dba8f..fc1ea70 100644
--- a/op.c
+++ b/op.c
@@ -216,6 +216,24 @@ S_Slab_to_rw(pTHX_ void *op)
 		  slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
     }
 }
+
+OP *
+Perl_op_refcnt_inc(pTHX_ OP *o)
+{
+    if(o) {
+	Slab_to_rw(o);
+	++o->op_targ;
+    }
+    return o;
+
+}
+
+PADOFFSET
+Perl_op_refcnt_dec(pTHX_ OP *o)
+{
+    Slab_to_rw(o);
+    return --o->op_targ;
+}
 #else
 #  define Slab_to_rw(op)
 #endif
@@ -249,17 +267,12 @@ Perl_Slab_Free(pTHX_ void *op)
 		    PL_slabs[count] = PL_slabs[--PL_slab_count];
 		    /* Could realloc smaller at this point, but probably not
 		       worth it.  */
-		    goto gotcha;
+		    if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
+			perror("munmap failed");
+			abort();
+		    }
+		    break;
 		}
-		
-	    }
-	    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
@@ -422,9 +435,6 @@ 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;
@@ -451,12 +461,13 @@ Perl_op_free(pTHX_ OP *o)
     if (type == OP_NULL)
 	type = (OPCODE)o->op_targ;
 
+#ifdef PERL_DEBUG_READONLY_OPS
+    Slab_to_rw(o);
+#endif
+
     /* COP* is not cleared by op_clear() so that we may track line
      * numbers etc even after null() */
     if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) {
-#ifdef PERL_DEBUG_READONLY_OPS
-	Slab_to_rw(o);
-#endif
 	cop_free((COP*)o);
     }
 
diff --git a/op.h b/op.h
index 2141e2b..2631fa8 100644
--- a/op.h
+++ b/op.h
@@ -590,8 +590,13 @@ struct loop {
 #endif
 
 #define OpREFCNT_set(o,n)		((o)->op_targ = (n))
-#define OpREFCNT_inc(o)			((o) ? (++(o)->op_targ, (o)) : NULL)
-#define OpREFCNT_dec(o)			(--(o)->op_targ)
+#ifdef PERL_DEBUG_READONLY_OPS
+#  define OpREFCNT_inc(o)		Perl_op_refcnt_inc(aTHX_ o)
+#  define OpREFCNT_dec(o)		Perl_op_refcnt_dec(aTHX_ o)
+#else
+#  define OpREFCNT_inc(o)		((o) ? (++(o)->op_targ, (o)) : NULL)
+#  define OpREFCNT_dec(o)		(--(o)->op_targ)
+#endif
 
 /* flags used by Perl_load_module() */
 #define PERL_LOADMOD_DENY		0x1
diff --git a/proto.h b/proto.h
index 436fa79..8bab32e 100644
--- a/proto.h
+++ b/proto.h
@@ -3331,6 +3331,10 @@ PERL_CALLCONV void	Perl_Slab_Free(pTHX_ void *op)
 
 #  if defined(PERL_DEBUG_READONLY_OPS)
 PERL_CALLCONV void	Perl_pending_Slabs_to_ro(pTHX);
+PERL_CALLCONV OP *	Perl_op_refcnt_inc(pTHX_ OP *o);
+PERL_CALLCONV PADOFFSET	Perl_op_refcnt_dec(pTHX_ OP *o)
+			__attribute__nonnull__(pTHX_1);
+
 #    if defined(PERL_IN_OP_C)
 STATIC void	S_Slab_to_rw(pTHX_ void *op)
 			__attribute__nonnull__(pTHX_1);