This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
op.c: Add debugging dump function
authorKarl Williamson <khw@cpan.org>
Tue, 19 Feb 2019 04:14:47 +0000 (21:14 -0700)
committerKarl Williamson <khw@cpan.org>
Thu, 7 Nov 2019 04:22:24 +0000 (21:22 -0700)
This function dumps out an inversion map

embed.fnc
embed.h
invlist_inline.h
op.c
proto.h

index 3b678c1..87c5159 100644 (file)
--- 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 44f50f1..425ba30 100644 (file)
--- a/embed.h
+++ b/embed.h
 #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
 #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)
index 795b895..76d6dda 100644 (file)
@@ -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 e08b769..12ee52a 100644 (file)
--- 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 4520772..20e4b0e 100644 (file)
--- 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__;