From e0be78213ff4362a011b8be77ba8af2d5a307178 Mon Sep 17 00:00:00 2001
From: Karl Williamson <khw@cpan.org>
Date: Wed, 4 Mar 2020 20:58:28 -0700
Subject: [PATCH] pp_match(): output regex debugging info

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 |  3 +++
 embed.h   |  1 +
 pp_hot.c  | 52 +++++++++++++++++++++++++++++++++++++++++++++++++---
 proto.h   |  8 ++++++++
 4 files changed, 61 insertions(+), 3 deletions(-)

diff --git a/embed.fnc b/embed.fnc
index fc9d8b4..09fce2a 100644
--- 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
--- a/embed.h
+++ b/embed.h
@@ -1835,6 +1835,7 @@
 #  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)
diff --git a/pp_hot.c b/pp_hot.c
index 1c4ff48..9698fb3 100644
--- 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
--- 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);
-- 
1.8.3.1