fix re debug segvs in global destruction, and a tweak to Benchmark to prevent infinite loops. (Re: ext/re/t/regop.pl SEGV)

Message-ID: <9b18b3110606140454p19f4241exae6528f1c7bb32d7@mail.gmail.com>

p4raw-id: //depot/perl@28393

5 files changed, 53 insertions, 35 deletions

diff --git a/ext/re/t/regop.pl b/ext/re/t/regop.pl
index a548fe4410..88f9f28cdb 100644
--- a/ext/re/t/regop.pl
+++ b/ext/re/t/regop.pl
@@ -1,4 +1,4 @@
-use re Debug=>qw(COMPILE EXECUTE OFFSETS);
+use re Debug=>qw(DUMP EXECUTE OFFSETS);
 my @tests=(
   XY     =>  'X(A|[B]Q||C|D)Y' ,
   foobar =>  '[f][o][o][b][a][r]',
diff --git a/lib/Benchmark.pm b/lib/Benchmark.pm
index 854851cfe3..24e339036f 100644
--- a/lib/Benchmark.pm
+++ b/lib/Benchmark.pm
@@ -552,6 +552,8 @@ sub timediff {
     for (my $i=0; $i < @$a; ++$i) {
 	push(@r, $a->[$i] - $b->[$i]);
     }
+    #die "Bad timediff(): ($r[1] + $r[2]) <= 0 (@$a[1,2]|@$b[1,2])\n"
+    #        if ($r[1] + $r[2]) < 0;
     bless \@r;
 }
 
@@ -717,9 +719,16 @@ sub countit {
     my ($n, $tc);
 
     # First find the minimum $n that gives a significant timing.
+    my $zeros=0;
     for ($n = 1; ; $n *= 2 ) {
 	my $td = timeit($n, $code);
 	$tc = $td->[1] + $td->[2];
+	if ( $tc <= 0 and $n > 1024 ) {
+	    ++$zeros > 16
+	        and die "Timing is consistently zero in estimation loop, cannot benchmark. N=$n\n";
+	} else {
+	    $zeros = 0;
+	}
 	last if $tc > 0.1;
     }
 
@@ -753,7 +762,7 @@ sub countit {
     # with stable times and avoiding extra timeit()s is nice for
     # accuracy's sake.
     $n = int( $n * ( 1.05 * $tmax / $tc ) );
-
+    $zeros=0;
     while () {
 	my $td = timeit($n, $code);
 	$ntot  += $n;
@@ -764,7 +773,12 @@ sub countit {
 	$cstot += $td->[4];
 	$ttot = $utot + $stot;
 	last if $ttot >= $tmax;
-
+	if ( $ttot <= 0 ) {
+	    ++$zeros > 16
+	        and die "Timing is consistently zero, cannot benchmark. N=$n\n";
+	} else {
+	    $zeros = 0;
+	}
         $ttot = 0.01 if $ttot < 0.01;
 	my $r = $tmax / $ttot - 1; # Linear approximation.
 	$n = int( $r * $ntot );
diff --git a/regcomp.c b/regcomp.c
index 8ea1dc6cec..c1b4dc70f6 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -6366,8 +6366,9 @@ Perl_regdump(pTHX_ const regexp *r)
 	    U32 i;
 	    PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)r->offsets[0]);
 	    for (i = 1; i <= len; i++) {
-	        PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
-		    i, (UV)r->offsets[i*2-1], (UV)r->offsets[i*2]);
+	        if (r->offsets[i*2-1] || r->offsets[i*2])
+	            PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
+		        i, (UV)r->offsets[i*2-1], (UV)r->offsets[i*2]);
             }
 	    PerlIO_printf(Perl_debug_log, "\n");
         });
@@ -6903,7 +6904,7 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
 	
 	/* Where, what. */
 	if (OP(node) == OPTIMIZED) {
-	    if (!optstart && (SvIV(re_debug_flags) & RE_DEBUG_COMPILE_OPTIMISE))
+	    if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
 	        optstart = node;
 	    else
 		goto after_print;
diff --git a/regcomp.h b/regcomp.h
index 8363637724..84a0e5027f 100644
--- a/regcomp.h
+++ b/regcomp.h
@@ -568,57 +568,62 @@ re.pm, especially to the documentation.
 #define RE_DEBUG_EXTRA_TRIE        0x010000
 #define RE_DEBUG_EXTRA_OFFSETS     0x020000
 
+#define RE_DEBUG_FLAG(x) (re_debug_flags & x)
 /* Compile */
 #define DEBUG_COMPILE_r(x) DEBUG_r( \
-    if (SvIV(re_debug_flags) & RE_DEBUG_COMPILE_MASK) x  )
+    if (re_debug_flags & RE_DEBUG_COMPILE_MASK) x  )
 #define DEBUG_PARSE_r(x) DEBUG_r( \
-    if (SvIV(re_debug_flags) & RE_DEBUG_COMPILE_PARSE) x  )
+    if (re_debug_flags & RE_DEBUG_COMPILE_PARSE) x  )
 #define DEBUG_OPTIMISE_r(x) DEBUG_r( \
-    if (SvIV(re_debug_flags) & RE_DEBUG_COMPILE_OPTIMISE) x  )
+    if (re_debug_flags & RE_DEBUG_COMPILE_OPTIMISE) x  )
 #define DEBUG_PARSE_r(x) DEBUG_r( \
-    if (SvIV(re_debug_flags) & RE_DEBUG_COMPILE_PARSE) x  )
+    if (re_debug_flags & RE_DEBUG_COMPILE_PARSE) x  )
 #define DEBUG_DUMP_r(x) DEBUG_r( \
-    if (SvIV(re_debug_flags) & RE_DEBUG_COMPILE_DUMP) x  )
+    if (re_debug_flags & RE_DEBUG_COMPILE_DUMP) x  )
 #define DEBUG_OFFSETS_r(x) DEBUG_r( \
-    if (SvIV(re_debug_flags) & RE_DEBUG_COMPILE_OFFSETS) x  )
+    if (re_debug_flags & RE_DEBUG_COMPILE_OFFSETS) x  )
 #define DEBUG_TRIE_COMPILE_r(x) DEBUG_r( \
-    if (SvIV(re_debug_flags) & RE_DEBUG_COMPILE_TRIE) x )
+    if (re_debug_flags & RE_DEBUG_COMPILE_TRIE) x )
 
 /* Execute */
 #define DEBUG_EXECUTE_r(x) DEBUG_r( \
-    if (SvIV(re_debug_flags) & RE_DEBUG_EXECUTE_MASK) x  )
+    if (re_debug_flags & RE_DEBUG_EXECUTE_MASK) x  )
 #define DEBUG_INTUIT_r(x) DEBUG_r( \
-    if (SvIV(re_debug_flags) & RE_DEBUG_EXECUTE_INTUIT) x  )
+    if (re_debug_flags & RE_DEBUG_EXECUTE_INTUIT) x  )
 #define DEBUG_MATCH_r(x) DEBUG_r( \
-    if (SvIV(re_debug_flags) & RE_DEBUG_EXECUTE_MATCH) x  )
+    if (re_debug_flags & RE_DEBUG_EXECUTE_MATCH) x  )
 #define DEBUG_TRIE_EXECUTE_r(x) DEBUG_r( \
-    if (SvIV(re_debug_flags) & RE_DEBUG_EXECUTE_TRIE) x )
+    if (re_debug_flags & RE_DEBUG_EXECUTE_TRIE) x )
 
 /* Extra */
 #define DEBUG_EXTRA_r(x) DEBUG_r( \
-    if (SvIV(re_debug_flags) & RE_DEBUG_EXTRA_MASK) x  )
+    if (re_debug_flags & RE_DEBUG_EXTRA_MASK) x  )
 #define MJD_OFFSET_DEBUG(x) DEBUG_r( \
-    if (SvIV(re_debug_flags) & RE_DEBUG_EXTRA_OFFSETS) \
+    if (re_debug_flags & RE_DEBUG_EXTRA_OFFSETS) \
         Perl_warn_nocontext x )
 #define DEBUG_TRIE_COMPILE_MORE_r(x) DEBUG_TRIE_COMPILE_r( \
-    if (SvIV(re_debug_flags) & RE_DEBUG_EXTRA_TRIE) x )
+    if (re_debug_flags & RE_DEBUG_EXTRA_TRIE) x )
 #define DEBUG_TRIE_EXECUTE_MORE_r(x) DEBUG_TRIE_EXECUTE_r( \
-    if (SvIV(re_debug_flags) & RE_DEBUG_EXTRA_TRIE) x )
+    if (re_debug_flags & RE_DEBUG_EXTRA_TRIE) x )
 
 #define DEBUG_TRIE_r(x) DEBUG_r( \
-    if (SvIV(re_debug_flags) & (RE_DEBUG_COMPILE_TRIE \
+    if (re_debug_flags & (RE_DEBUG_COMPILE_TRIE \
         | RE_DEBUG_EXECUTE_TRIE )) x )
 
 /* initialization */
 /* get_sv() can return NULL during global destruction. */
-#define GET_RE_DEBUG_FLAGS DEBUG_r( \
-        re_debug_flags = get_sv(RE_DEBUG_FLAGS, 1); \
-        if (re_debug_flags && !SvIOK(re_debug_flags)) { \
-            sv_setiv(re_debug_flags, RE_DEBUG_COMPILE_DUMP | RE_DEBUG_EXECUTE_MASK ); \
-        } )
+#define GET_RE_DEBUG_FLAGS DEBUG_r({ \
+        SV * re_debug_flags_sv = NULL; \
+        re_debug_flags_sv = get_sv(RE_DEBUG_FLAGS, 1); \
+        if (re_debug_flags_sv) { \
+            if (!SvUOK(re_debug_flags_sv)) \
+                sv_setuv(re_debug_flags_sv, RE_DEBUG_COMPILE_DUMP | RE_DEBUG_EXECUTE_MASK ); \
+            re_debug_flags=SvUV(re_debug_flags_sv); \
+        }\
+})
 
 #ifdef DEBUGGING
-#define GET_RE_DEBUG_FLAGS_DECL SV *re_debug_flags = NULL; GET_RE_DEBUG_FLAGS;
+#define GET_RE_DEBUG_FLAGS_DECL UV re_debug_flags = 0; GET_RE_DEBUG_FLAGS;
 #else
 #define GET_RE_DEBUG_FLAGS_DECL
 #endif
diff --git a/regexec.c b/regexec.c
index f93e17e530..6ac241e40d 100644
--- a/regexec.c
+++ b/regexec.c
@@ -2750,8 +2750,7 @@ S_regmatch(pTHX_ const regmatch_info *reginfo, regnode *prog)
 							    subpattern */
     
 #ifdef DEBUGGING
-    SV *re_debug_flags = NULL;
-    GET_RE_DEBUG_FLAGS;
+    GET_RE_DEBUG_FLAGS_DECL;
     PL_regindent++;
 #endif
 
@@ -5128,12 +5127,11 @@ S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max)
     PL_reginput = scan;
 
     DEBUG_r({
-	SV *re_debug_flags = NULL;
-	SV * const prop = sv_newmortal();
-	GET_RE_DEBUG_FLAGS;
+	GET_RE_DEBUG_FLAGS_DECL;
 	DEBUG_EXECUTE_r({
-	regprop(prog, prop, p);
-	PerlIO_printf(Perl_debug_log,
+	    SV * const prop = sv_newmortal();
+	    regprop(prog, prop, p);
+	    PerlIO_printf(Perl_debug_log,
 			"%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
 			REPORT_CODE_OFF+1, "", SvPVX_const(prop),(IV)c,(IV)max);
 	});