fix re debug segvs in global destruction, and a tweak to Benchmark to prevent infinit...

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

p4raw-id: //depot/perl@28393

diff --git a/ext/re/t/regop.pl b/ext/re/t/regop.pl
index a548fe4..88f9f28 100644 (file)
--- 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 854851c..24e3390 100644 (file)
--- 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 8ea1dc6..c1b4dc7 100644 (file)
--- 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 8363637..84a0e50 100644 (file)
--- 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 f93e17e..6ac241e 100644 (file)
--- 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);
        });