op.c: Add debugging dump function

This function dumps out an inversion map

5 files changed, 53 insertions, 4 deletions

diff --git a/embed.fnc b/embed.fnc
index 3b678c16a2..87c5159b8c 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1506,6 +1506,7 @@ p	|OP*	|pmruntime	|NN OP *o|NN OP *expr|NULLOK OP *repl \
 #if defined(PERL_IN_OP_C)
 S	|OP*	|pmtrans	|NN OP* o|NN OP* expr|NN OP* repl
 #endif
+p	|void	|invmap_dump	|NN SV* invlist|NN UV * map
 Ap	|void	|pop_scope
 Ap	|void	|push_scope
 #if defined(PERL_IN_PERLY_C) || defined(PERL_IN_OP_C) || defined(PERL_IN_TOKE_C)
@@ -1919,7 +1920,9 @@ EXpR	|SV*	|_setup_canned_invlist|const STRLEN size|const UV element0|NN UV** oth
 #if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_SV_C)
 EpX	|SV*	|invlist_clone	|NN SV* const invlist|NULLOK SV* newlist
 #endif
-#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_UTF8_C) || defined(PERL_IN_PP_C)
+#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C)	\
+ || defined(PERL_IN_TOKE_C) || defined(PERL_IN_UTF8_C)		\
+ || defined(PERL_IN_PP_C) || defined(PERL_IN_OP_C)
 EiRT	|UV*	|invlist_array	|NN SV* const invlist
 EiRT	|bool	|is_invlist	|NULLOK SV* const invlist
 EiRT	|bool*	|get_invlist_offset_addr|NN SV* invlist
diff --git a/embed.h b/embed.h
index 44f50f1d20..425ba304da 100644
--- a/embed.h
+++ b/embed.h
@@ -1094,7 +1094,7 @@
 #endif
 #define regprop(a,b,c,d,e)	Perl_regprop(aTHX_ a,b,c,d,e)
 #  endif
-#  if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_UTF8_C) || defined(PERL_IN_PP_C)
+#  if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C)	 || defined(PERL_IN_TOKE_C) || defined(PERL_IN_UTF8_C)		 || defined(PERL_IN_PP_C) || defined(PERL_IN_OP_C)
 #define _invlist_contains_cp	S__invlist_contains_cp
 #define _invlist_len		S__invlist_len
 #define _invlist_search		Perl__invlist_search
@@ -1288,6 +1288,7 @@
 #define init_named_cv(a,b)	Perl_init_named_cv(aTHX_ a,b)
 #define init_uniprops()		Perl_init_uniprops(aTHX)
 #define invert(a)		Perl_invert(aTHX_ a)
+#define invmap_dump(a,b)	Perl_invmap_dump(aTHX_ a,b)
 #define io_close(a,b,c,d)	Perl_io_close(aTHX_ a,b,c,d)
 #define isinfnansv(a)		Perl_isinfnansv(aTHX_ a)
 #define jmaybe(a)		Perl_jmaybe(aTHX_ a)
diff --git a/invlist_inline.h b/invlist_inline.h
index 795b8952a0..76d6dda998 100644
--- a/invlist_inline.h
+++ b/invlist_inline.h
@@ -13,7 +13,8 @@
  || defined(PERL_IN_REGCOMP_C)          \
  || defined(PERL_IN_REGEXEC_C)          \
  || defined(PERL_IN_TOKE_C)             \
- || defined(PERL_IN_PP_C)
+ || defined(PERL_IN_PP_C)               \
+ || defined(PERL_IN_OP_C)
 
 /* An element is in an inversion list iff its index is even numbered: 0, 2, 4,
  * etc */
diff --git a/op.c b/op.c
index e08b769858..12ee52a453 100644
--- a/op.c
+++ b/op.c
@@ -164,6 +164,7 @@ recursive, but it's recursive on basic blocks, not on tree nodes.
 #include "keywords.h"
 #include "feature.h"
 #include "regcomp.h"
+#include "invlist_inline.h"
 
 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
@@ -6713,6 +6714,46 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
     return fold_constants(op_integerize(op_std_init((OP *)binop)));
 }
 
+void
+Perl_invmap_dump(pTHX_ SV* invlist, UV *map)
+{
+    const char indent[] = "    ";
+
+    UV len = _invlist_len(invlist);
+    UV * array = invlist_array(invlist);
+    UV i;
+
+    PERL_ARGS_ASSERT_INVMAP_DUMP;
+
+    for (i = 0; i < len; i++) {
+        UV start = array[i];
+        UV end   = (i + 1 < len) ? array[i+1] - 1 : IV_MAX;
+
+        PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start);
+        if (end == IV_MAX) {
+            PerlIO_printf(Perl_debug_log, " .. INFTY");
+	}
+	else if (end != start) {
+            PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end);
+	}
+        else {
+            PerlIO_printf(Perl_debug_log, "            ");
+        }
+
+        PerlIO_printf(Perl_debug_log, "\t");
+
+        if (map[i] == TR_UNLISTED) {
+            PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n");
+        }
+        else if (map[i] == TR_SPECIAL_HANDLING) {
+            PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n");
+        }
+        else {
+            PerlIO_printf(Perl_debug_log, "0x%04" UVXf "\n", map[i]);
+        }
+    }
+}
+
 /* Helper function for S_pmtrans(): comparison function to sort an array
  * of codepoint range pairs. Sorts by start point, or if equal, by end
  * point */
diff --git a/proto.h b/proto.h
index 4520772315..20e4b0e511 100644
--- a/proto.h
+++ b/proto.h
@@ -1548,6 +1548,9 @@ PERL_CALLCONV OP*	Perl_invert(pTHX_ OP* cmd)
 			__attribute__warn_unused_result__;
 #define PERL_ARGS_ASSERT_INVERT
 
+PERL_CALLCONV void	Perl_invmap_dump(pTHX_ SV* invlist, UV * map);
+#define PERL_ARGS_ASSERT_INVMAP_DUMP	\
+	assert(invlist); assert(map)
 PERL_CALLCONV bool	Perl_io_close(pTHX_ IO* io, GV *gv, bool not_implicit, bool warn_on_fail);
 #define PERL_ARGS_ASSERT_IO_CLOSE	\
 	assert(io)
@@ -5829,7 +5832,7 @@ PERL_CALLCONV void	Perl_regprop(pTHX_ const regexp *prog, SV* sv, const regnode*
 #define PERL_ARGS_ASSERT_REGPROP	\
 	assert(sv); assert(o)
 #endif
-#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_UTF8_C) || defined(PERL_IN_PP_C)
+#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C)	 || defined(PERL_IN_TOKE_C) || defined(PERL_IN_UTF8_C)		 || defined(PERL_IN_PP_C) || defined(PERL_IN_OP_C)
 #ifndef PERL_NO_INLINE_FUNCTIONS
 PERL_STATIC_INLINE bool	S__invlist_contains_cp(SV* const invlist, const UV cp)
 			__attribute__warn_unused_result__;