Merge improvements to -DPERL_DEBUG_READONLY_OPS into blead.

All tests pass with -Dusethreads -DPERL_DEBUG_READONLY_OPS (on this system)
schacon · Sep 4, 2012 · b4503eb · b4503eb
2 parents 2d1c556 + f3e2910
commit b4503eb
Show file tree

Hide file tree

Showing 7 changed files with 44 additions and 40 deletions.
diff --git a/embed.fnc b/embed.fnc
@@ -1797,14 +1797,12 @@ Xp	|void	|Slab_Free	|NN void *op
 #if defined(PERL_DEBUG_READONLY_OPS)
 #    if defined(PERL_CORE)
 px	|void	|Slab_to_ro	|NN OPSLAB *slab
+px	|void	|Slab_to_rw	|NN OPSLAB *const slab
 #    endif
 : Used in OpREFCNT_inc() in sv.c
 poxM	|OP *	|op_refcnt_inc	|NULLOK OP *o
 : FIXME - can be static.
 poxM	|PADOFFSET	|op_refcnt_dec	|NN OP *o
-#    if defined(PERL_IN_OP_C)
-s	|void	|Slab_to_rw	|NN void *op
-#    endif
 #endif
 
 #if defined(PERL_IN_PERL_C)

diff --git a/embed.h b/embed.h
@@ -1319,6 +1319,7 @@
 #define opslab_free_nopad(a)	Perl_opslab_free_nopad(aTHX_ a)
 #    if defined(PERL_DEBUG_READONLY_OPS)
 #define Slab_to_ro(a)		Perl_Slab_to_ro(aTHX_ a)
+#define Slab_to_rw(a)		Perl_Slab_to_rw(aTHX_ a)
 #    endif
 #  endif
 #  if defined(PERL_CR_FILTER)
@@ -1327,11 +1328,6 @@
 #define strip_return(a)		S_strip_return(aTHX_ a)
 #    endif
 #  endif
-#  if defined(PERL_DEBUG_READONLY_OPS)
-#    if defined(PERL_IN_OP_C)
-#define Slab_to_rw(a)		S_Slab_to_rw(aTHX_ a)
-#    endif
-#  endif
 #  if defined(PERL_IN_AV_C)
 #define get_aux_mg(a)		S_get_aux_mg(aTHX_ a)
 #  endif

diff --git a/mg.c b/mg.c
@@ -2020,11 +2020,17 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
     if (svp && SvIOKp(*svp)) {
 	OP * const o = INT2PTR(OP*,SvIVX(*svp));
 	if (o) {
+#ifdef PERL_DEBUG_READONLY_OPS
+	    Slab_to_rw(OpSLAB(o));
+#endif
 	    /* set or clear breakpoint in the relevant control op */
 	    if (i)
 		o->op_flags |= OPf_SPECIAL;
 	    else
 		o->op_flags &= ~OPf_SPECIAL;
+#ifdef PERL_DEBUG_READONLY_OPS
+	    Slab_to_ro(OpSLAB(o));
+#endif
 	}
     }
     return 0;

diff --git a/op.c b/op.c
@@ -261,18 +261,13 @@ Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
     }
 }
 
-STATIC void
-S_Slab_to_rw(pTHX_ void *op)
+void
+Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 {
-    OP * const o = (OP *)op;
-    OPSLAB *slab;
     OPSLAB *slab2;
 
     PERL_ARGS_ASSERT_SLAB_TO_RW;
 
-    if (!o->op_slabbed) return;
-
-    slab = OpSLAB(o);
     if (!slab->opslab_readonly) return;
     slab2 = slab;
     for (; slab2; slab2 = slab2->opslab_next) {
@@ -406,8 +401,14 @@ OP *
 Perl_op_refcnt_inc(pTHX_ OP *o)
 {
     if(o) {
-	Slab_to_rw(o);
-	++o->op_targ;
+        OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
+        if (slab && slab->opslab_readonly) {
+            Slab_to_rw(slab);
+            ++o->op_targ;
+            Slab_to_ro(slab);
+        } else {
+            ++o->op_targ;
+        }
     }
     return o;
 
@@ -416,9 +417,19 @@ Perl_op_refcnt_inc(pTHX_ OP *o)
 PADOFFSET
 Perl_op_refcnt_dec(pTHX_ OP *o)
 {
+    PADOFFSET result;
+    OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
+
     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
-    Slab_to_rw(o);
-    return --o->op_targ;
+
+    if (slab && slab->opslab_readonly) {
+        Slab_to_rw(slab);
+        result = --o->op_targ;
+        Slab_to_ro(slab);
+    } else {
+        result = --o->op_targ;
+    }
+    return result;
 }
 #endif
 /*
@@ -698,7 +709,8 @@ Perl_op_free(pTHX_ OP *o)
     if (type == OP_NULL)
 	type = (OPCODE)o->op_targ;
 
-    Slab_to_rw(o);
+    if (o->op_slabbed)
+        Slab_to_rw(OpSLAB(o));
 
     /* COP* is not cleared by op_clear() so that we may track line
      * numbers etc even after null() */

diff --git a/pad.c b/pad.c
@@ -505,35 +505,29 @@ void
 Perl_cv_forget_slab(pTHX_ CV *cv)
 {
     const bool slabbed = !!CvSLABBED(cv);
-#ifdef PERL_DEBUG_READONLY_OPS
     OPSLAB *slab = NULL;
-#endif
 
     PERL_ARGS_ASSERT_CV_FORGET_SLAB;
 
     if (!slabbed) return;
 
     CvSLABBED_off(cv);
 
-#ifdef PERL_DEBUG_READONLY_OPS
     if      (CvROOT(cv))  slab = OpSLAB(CvROOT(cv));
     else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
-#else
-    if      (CvROOT(cv))  OpslabREFCNT_dec(OpSLAB(CvROOT(cv)));
-    else if (CvSTART(cv)) OpslabREFCNT_dec((OPSLAB *)CvSTART(cv));
-#endif
 #ifdef DEBUGGING
     else if (slabbed)     Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
 #endif
 
-#ifdef PERL_DEBUG_READONLY_OPS
     if (slab) {
-	size_t refcnt;
-	refcnt = slab->opslab_refcnt;
+#ifdef PERL_DEBUG_READONLY_OPS
+	const size_t refcnt = slab->opslab_refcnt;
+#endif
 	OpslabREFCNT_dec(slab);
+#ifdef PERL_DEBUG_READONLY_OPS
 	if (refcnt > 1) Slab_to_ro(slab);
-    }
 #endif
+    }
 }
 
 /*

diff --git a/pp.c b/pp.c
@@ -2364,7 +2364,7 @@ PP(pp_i_divide)
     }
 }
 
-#if defined(__GLIBC__) && IVSIZE == 8
+#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
 STATIC
 PP(pp_i_modulo_0)
 #else
@@ -2387,7 +2387,7 @@ PP(pp_i_modulo)
      }
 }
 
-#if defined(__GLIBC__) && IVSIZE == 8
+#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
 STATIC
 PP(pp_i_modulo_1)
 

diff --git a/proto.h b/proto.h
@@ -5304,6 +5304,11 @@ PERL_CALLCONV void	Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 #define PERL_ARGS_ASSERT_SLAB_TO_RO	\
 	assert(slab)
 
+PERL_CALLCONV void	Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SLAB_TO_RW	\
+	assert(slab)
+
 #  endif
 #endif
 #if defined(PERL_CR_FILTER)
@@ -5323,13 +5328,6 @@ PERL_CALLCONV PADOFFSET	Perl_op_refcnt_dec(pTHX_ OP *o)
 	assert(o)
 
 PERL_CALLCONV OP *	Perl_op_refcnt_inc(pTHX_ OP *o);
-#  if defined(PERL_IN_OP_C)
-STATIC void	S_Slab_to_rw(pTHX_ void *op)
-			__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_SLAB_TO_RW	\
-	assert(op)
-
-#  endif
 #endif
 #if defined(PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION)
 /* PERL_CALLCONV bool	Perl_do_exec(pTHX_ const char* cmd)