This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pp_match(): output regex debugging info
authorKarl Williamson <khw@cpan.org>
Thu, 5 Mar 2020 03:58:28 +0000 (20:58 -0700)
committerKarl Williamson <khw@cpan.org>
Wed, 18 Mar 2020 23:38:19 +0000 (17:38 -0600)
This fixes #17612

This adds an inline function to pp_hot to be called to determine if
debugging info should be output or not, regardless of whether it comes
from -Dr, or from a 'use re Debug' statement

embed.fnc
embed.h
pp_hot.c
proto.h

index fc9d8b4..09fce2a 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2844,6 +2844,9 @@ pReo      |GV*    |softref2xv     |NN SV *const sv|NN const char *const what \
                                |const svtype type|NN SV ***spp
 iTR    |bool   |lossless_NV_to_IV|const NV nv|NN IV * ivp
 #endif
+#if defined(PERL_IN_PP_HOT_C)
+IR     |bool   |should_we_output_Debug_r|NN regexp * prog
+#endif
 
 #if defined(PERL_IN_PP_PACK_C)
 S      |SSize_t|unpack_rec     |NN struct tempsym* symptr|NN const char *s \
diff --git a/embed.h b/embed.h
index 588ffba..a76a43f 100644 (file)
--- a/embed.h
+++ b/embed.h
 #  if defined(PERL_IN_PP_HOT_C)
 #define do_oddball(a,b)                S_do_oddball(aTHX_ a,b)
 #define opmethod_stash(a)      S_opmethod_stash(aTHX_ a)
+#define should_we_output_Debug_r(a)    S_should_we_output_Debug_r(aTHX_ a)
 #  endif
 #  if defined(PERL_IN_PP_PACK_C)
 #define div128(a,b)            S_div128(aTHX_ a,b)
index 1c4ff48..9698fb3 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -34,6 +34,7 @@
 #include "EXTERN.h"
 #define PERL_IN_PP_HOT_C
 #include "perl.h"
+#include "regcomp.h"
 
 /* Hot code. */
 
@@ -2889,6 +2890,47 @@ PP(pp_qr)
     RETURN;
 }
 
+STATIC bool
+S_are_we_in_Debug_EXECUTE_r(pTHX)
+{
+    /* Given a 'use re' is in effect, does it ask for outputting execution
+     * debug info?
+     *
+     * This is separated from the sole place it's called, an inline function,
+     * because it is the large-ish slow portion of the function */
+
+    DECLARE_AND_GET_RE_DEBUG_FLAGS_NON_REGEX;
+
+    return cBOOL(RE_DEBUG_FLAG(RE_DEBUG_EXECUTE_MASK));
+}
+
+PERL_STATIC_INLINE bool
+S_should_we_output_Debug_r(pTHX_ regexp *prog)
+{
+    PERL_ARGS_ASSERT_SHOULD_WE_OUTPUT_DEBUG_R;
+
+    /* pp_match can output regex debugging info.  This function returns a
+     * boolean as to whether or not it should.
+     *
+     * Under -Dr, it should.  Any reasonable compiler will optimize this bit of
+     * code away on non-debugging builds. */
+    if (UNLIKELY(DEBUG_r_TEST)) {
+        return TRUE;
+    }
+
+    /* If the regex engine is using the non-debugging execution routine, then
+     * no debugging should be output.  Same if the field is NULL that pluggable
+     * engines are not supposed to fill. */
+    if (     LIKELY(prog->engine->exec == &Perl_regexec_flags)
+        || UNLIKELY(prog->engine->op_comp == NULL))
+    {
+        return FALSE;
+    }
+
+    /* Otherwise have to check */
+    return S_are_we_in_Debug_EXECUTE_r(aTHX);
+}
+
 PP(pp_match)
 {
     dSP; dTARG;
@@ -2944,7 +2986,9 @@ PP(pp_match)
         pm->op_pmflags & PMf_USED
 #endif
     ) {
-        DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
+        if (UNLIKELY(should_we_output_Debug_r(prog))) {
+            PerlIO_printf(Perl_debug_log, "?? already matched once");
+        }
        goto nope;
     }
 
@@ -2966,9 +3010,11 @@ PP(pp_match)
     }
 
     if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) {
-        DEBUG_r(PerlIO_printf(Perl_debug_log,
+        if (UNLIKELY(should_we_output_Debug_r(prog))) {
+            PerlIO_printf(Perl_debug_log,
                 "String shorter than min possible regex match (%zd < %zd)\n",
-                                                        len, RXp_MINLEN(prog)));
+                                                        len, RXp_MINLEN(prog));
+        }
        goto nope;
     }
 
diff --git a/proto.h b/proto.h
index 6306918..543bfbd 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -5520,6 +5520,14 @@ PERL_STATIC_INLINE HV*   S_opmethod_stash(pTHX_ SV* meth);
 #define PERL_ARGS_ASSERT_OPMETHOD_STASH        \
        assert(meth)
 #endif
+#ifndef PERL_NO_INLINE_FUNCTIONS
+PERL_STATIC_FORCE_INLINE bool  S_should_we_output_Debug_r(pTHX_ regexp * prog)
+                       __attribute__warn_unused_result__
+                       __attribute__always_inline__;
+#define PERL_ARGS_ASSERT_SHOULD_WE_OUTPUT_DEBUG_R      \
+       assert(prog)
+#endif
+
 #endif
 #if defined(PERL_IN_PP_PACK_C)
 STATIC int     S_div128(pTHX_ SV *pnum, bool *done);