develooper Front page | perl.perl5.porters | Postings from January 2012

Bad free with COW scalars [perl #37038]

From:
Father Chrysostomos
Date:
January 15, 2012 12:47
Subject:
Bad free with COW scalars [perl #37038]
Message ID:
10F1184A-2A44-4DEF-B916-B87CE48A8869@cpan.org
I was trying to force the pre-match copy to do COW, for the sake of fixing //g without slowing it down (bugs #37038 and #46563).

I ran into some interesting ‘panic: bad free’ errors, and I can’t figure out why.

I suspect there is still some problem with sv_sethek.

See the attached patch (where I’ve changed the error to an abort, so that gdb will stop there).

It fails for me in the middle of autodoc.pl, but the line number it stops on doesn’t seem particularly informative.

If you comment out the indicated sv_sethek line, the problem goes away, but so does the speed-up I was trying to get.

Actually, if I change the offending line to

		sv_setsv_nomg(sv, sv_2mortal(newSVhek(hek)));

the problem persists.  So it seems to be related to shared heks in general.

Am I doing something obviously wrong?

diff --git a/dump.c b/dump.c
index 2c635de..b5ef034 100644
--- a/dump.c
+++ b/dump.c
@@ -2063,10 +2063,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 				PTR2UV(r->pprivate));
 	    Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%"UVxf"\n",
 				PTR2UV(r->offs));
-#ifdef PERL_OLD_COPY_ON_WRITE
 	    Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%"UVxf"\n",
 				PTR2UV(r->saved_copy));
-#endif
 	}
 	break;
     }
diff --git a/regcomp.c b/regcomp.c
index 4669c27..a9da541 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -11757,9 +11757,7 @@ Perl_pregfree2(pTHX_ REGEXP *rx)
 	Safefree(r->substrs);
     }
     RX_MATCH_COPY_FREE(rx);
-#ifdef PERL_OLD_COPY_ON_WRITE
     SvREFCNT_dec(r->saved_copy);
-#endif
     Safefree(r->offs);
 }
 
@@ -11820,9 +11818,7 @@ Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
 	   anchored or float namesakes, and don't hold a second reference.  */
     }
     RX_MATCH_COPIED_off(ret_x);
-#ifdef PERL_OLD_COPY_ON_WRITE
     ret->saved_copy = NULL;
-#endif
     ret->mother_re = rx;
     
     return ret_x;
@@ -12040,9 +12036,7 @@ Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
 	ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
     else
 	ret->subbeg = NULL;
-#ifdef PERL_OLD_COPY_ON_WRITE
     ret->saved_copy = NULL;
-#endif
 
     if (ret->mother_re) {
 	if (SvPVX_const(dstr) == SvPVX_const(ret->mother_re)) {
diff --git a/regexec.c b/regexec.c
index 44d7b96..259446d 100644
--- a/regexec.c
+++ b/regexec.c
@@ -2510,9 +2510,28 @@ got_it:
 		prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
 		prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
 		assert (SvPOKp(prog->saved_copy));
-	    } else
+#else
+	    if (SvIsCOW(sv)) {
+		if (!prog->saved_copy) prog->saved_copy = newSV(0);
+		sv_setsv_nomg(prog->saved_copy, sv);
+		prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
+	    }
+	    else if ((STRLEN)i == SvCUR(sv)
+		  && (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS) {
+		/* Force a COW.  Creating a shared string makes exactly
+		   one copy, which we were going to make anyway.  If this
+		   string will be subjected to multiple matches, this will
+		   save us making another copy for each match. */
+		HEK *hek = share_hek(strbeg, SvUTF8(sv) ? -i : i, 0);
+	/* comment out the following line to avoid the error: */
+		sv_sethek(sv, hek);
+		if (prog->saved_copy) sv_sethek(prog->saved_copy, hek);
+		else prog->saved_copy = newSVhek(hek);
+		unshare_hek(hek);
+		prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
 #endif
-	    {
+	    }
+	    else {
 		RX_MATCH_COPIED_on(rx);
 		s = savepvn(strbeg, i);
 		prog->subbeg = s;
diff --git a/regexp.h b/regexp.h
index 5ee6448..43186a5 100644
--- a/regexp.h
+++ b/regexp.h
@@ -44,12 +44,6 @@ struct reg_substr_data {
     struct reg_substr_datum data[3];	/* Actual array */
 };
 
-#ifdef PERL_OLD_COPY_ON_WRITE
-#define SV_SAVED_COPY   SV *saved_copy; /* If non-NULL, SV which is COW from original */
-#else
-#define SV_SAVED_COPY
-#endif
-
 typedef struct regexp_paren_pair {
     I32 start;
     I32 end;
@@ -94,7 +88,7 @@ typedef struct regexp_paren_pair {
 	regexp_paren_pair *offs;					\
 	/* saved or original string so \digit works forever. */		\
 	char *subbeg;							\
-	SV_SAVED_COPY	/* If non-NULL, SV which is COW from original */\
+	SV *saved_copy;	/* If non-NULL, SV which is COW from original */\
 	I32 sublen;	/* Length of string pointed by subbeg */	\
 	/* Information about the match that isn't often used */		\
 	/* offset from wrapped to the start of precomp */		\
diff --git a/util.c b/util.c
index 9d7683d..ef5f1a0 100644
--- a/util.c
+++ b/util.c
@@ -265,6 +265,7 @@ Perl_safesysfree(Malloc_t where)
 	    }
 	    if (!(header->next) || header->next->prev != header
 		|| header->prev->next != header) {
+abort();
 		Perl_croak_nocontext("panic: bad free");
 	    }
 	    /* Unlink us from the chain.  */




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