Skip to content

Improve -Dy debugging #23591

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 5 commits into from
Aug 23, 2025
Merged

Improve -Dy debugging #23591

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
1104476
Convert _pv_display_flags to legal name
khwilliamson Aug 16, 2025
518fe91
Create embed.fnc entry for pv_display_flags_
khwilliamson Aug 14, 2025
6c15aee
op.c: Combine some adjacent -Dy source lines
khwilliamson Aug 17, 2025
682fe13
Add detail to -Dy debugging
khwilliamson Aug 17, 2025
bff6937
op.c: Change a -Dy line to yv; and another vice versa
khwilliamson Aug 17, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
10 changes: 6 additions & 4 deletions dump.c
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -95,7 +95,7 @@ S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
| ((utf8) ? PERL_PV_ESCAPE_UNI : 0) )

#define _pv_display_for_dump(dsv, pv, cur, len, pvlim) \
_pv_display_flags(aTHX_ dsv, pv, cur, len, pvlim, PERL_PV_ESCAPE_DWIM_ALL_HEX)
pv_display_flags(dsv, pv, cur, len, pvlim, PERL_PV_ESCAPE_DWIM_ALL_HEX)

/*
=for apidoc pv_escape
Expand Down Expand Up @@ -417,9 +417,9 @@ Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
}

STATIC char *
_pv_display_flags(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim, I32 pretty_flags)
S_pv_display_flags(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim, I32 pretty_flags)
{
PERL_ARGS_ASSERT_PV_DISPLAY;
PERL_ARGS_ASSERT_PV_DISPLAY_FLAGS;

pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP | pretty_flags );
if (len > cur && pv[cur] == '\0')
Expand All @@ -445,7 +445,9 @@ Note that the final string may be up to 7 chars longer than pvlim.
char *
Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
{
return _pv_display_flags(aTHX_ dsv, pv, cur, len, pvlim, 0);
PERL_ARGS_ASSERT_PV_DISPLAY;

return pv_display_flags(dsv, pv, cur, len, pvlim, 0);
}

/*
Expand Down
13 changes: 13 additions & 0 deletions embed.fnc
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4460,6 +4460,13 @@ ERXp |const char *|form_cp_too_large_msg \
S |CV * |deb_curcv |I32 ix
Sd |void |debprof |NN const OP *o
S |SV * |pm_description |NN const PMOP *pm
S |char * |pv_display_flags \
|NN SV *dsv \
|NN const char *pv \
|STRLEN cur \
|STRLEN len \
|STRLEN pvlim \
|I32 pretty_flags
S |UV |sequence_num |NULLOK const OP *o
#endif
#if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || \
Expand Down Expand Up @@ -4962,6 +4969,12 @@ S |OP * |too_many_arguments_pv \
|NN const char *name \
|U32 flags
S |OP * |voidnonfinal |NULLOK OP *o
# if defined(DEBUGGING)
S |const char *|get_displayable_tr_operand \
|NN const U8 *s \
|STRLEN len \
|bool is_utf8
# endif
#endif /* defined(PERL_IN_OP_C) */
#if defined(PERL_IN_OP_C) || defined(PERL_IN_PAD_C)
Ti |bool |PadnameIN_SCOPE|NN const PADNAME * const pn \
Expand Down
4 changes: 4 additions & 0 deletions embed.h
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -1340,6 +1340,7 @@
# define deb_curcv(a) S_deb_curcv(aTHX_ a)
# define debprof(a) S_debprof(aTHX_ a)
# define pm_description(a) S_pm_description(aTHX_ a)
# define pv_display_flags(a,b,c,d,e,f) S_pv_display_flags(aTHX_ a,b,c,d,e,f)
# define sequence_num(a) S_sequence_num(aTHX_ a)
# endif
# if defined(PERL_IN_GV_C)
Expand Down Expand Up @@ -1518,6 +1519,9 @@
# define too_few_arguments_pv(a,b,c) S_too_few_arguments_pv(aTHX_ a,b,c)
# define too_many_arguments_pv(a,b,c) S_too_many_arguments_pv(aTHX_ a,b,c)
# define voidnonfinal(a) S_voidnonfinal(aTHX_ a)
# if defined(DEBUGGING)
# define get_displayable_tr_operand(a,b,c) S_get_displayable_tr_operand(aTHX_ a,b,c)
# endif
# endif /* defined(PERL_IN_OP_C) */
# if defined(PERL_IN_OP_C) || defined(PERL_IN_PAD_C)
# define PadnameIN_SCOPE S_PadnameIN_SCOPE
Expand Down
117 changes: 99 additions & 18 deletions op.c
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -6179,6 +6179,25 @@ Perl_invmap_dump(pTHX_ SV* invlist, UV *map)
}
}

#ifdef DEBUGGING

static const char *
S_get_displayable_tr_operand(pTHX_ const U8 * s, STRLEN len, bool is_utf8)
{
SV * output = sv_2mortal(newSVpvs(""));
if (is_utf8) {
return pv_uni_display(output, s, len, 1000, UNI_DISPLAY_TR_);
}
else {
return pv_pretty(output, (const char *) s, len, 256, NULL, NULL,
( PERL_PV_ESCAPE_NONASCII
|PERL_PV_PRETTY_LTGT
|PERL_PV_PRETTY_ELLIPSES));
}
}

#endif

/* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
* containing the search and replacement strings, assemble into
* a translation table attached as o->op_pv.
Expand Down Expand Up @@ -6528,6 +6547,13 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)

PL_hints |= HINT_BLOCK_SCOPE;

DEBUG_y(PerlIO_printf(Perl_debug_log,
"%s: %d: Compiling tr/*t/*r/; /c=%d; /d=%d; /s=%d\n"
"*t is '%s'\n*r is '%s'\n",
__FILE__, __LINE__, complement, del, squash,
get_displayable_tr_operand(t0, tlen, tstr_utf8),
get_displayable_tr_operand(r0, rlen, rstr_utf8)));

/* If /c, the search list is sorted and complemented. This is now done by
* creating an inversion list from it, and then trivially inverting that.
* The previous implementation used qsort, but creating the list
Expand Down Expand Up @@ -6609,6 +6635,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
tend = t0 + temp_len;
tstr_utf8 = TRUE;

DEBUG_y(PerlIO_printf(Perl_debug_log,
"%s: %d: *t after complementing=\n%s\n",
__FILE__, __LINE__,
get_displayable_tr_operand(t0, temp_len, tstr_utf8)));

SvREFCNT_dec_NN(inverted_tlist);
}

Expand Down Expand Up @@ -6653,8 +6684,8 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
for (pass2 = 0; pass2 < 2; pass2++) {
if (pass2) {

DEBUG_yv(PerlIO_printf(Perl_debug_log, "After pass1: \n"));
DEBUG_yv(invmap_dump(t_invlist, r_map));
DEBUG_y(PerlIO_printf(Perl_debug_log, "After pass1: \n");
invmap_dump(t_invlist, r_map));

/* In the second pass, we start with a single range */
t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
Expand Down Expand Up @@ -6786,9 +6817,9 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
r_range_count = t_range_count;

#ifdef DEBUGGING
if (DEBUG_y_TEST && ! del) {
if (DEBUG_yv_TEST && ! del) {
PerlIO_printf(Perl_debug_log,
"final_map =%" UVXf "\n", final_map);
"final_map = %" UVXf "\n", final_map);
}
#endif
}
Expand Down Expand Up @@ -6904,9 +6935,25 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
* has been set up so that all members in it will be of the same
* ilk) */
if (r_map[i] == TR_UNLISTED) {
DEBUG_yv(PerlIO_printf(Perl_debug_log,
"Processing %" UVxf "-%" UVxf " => %" UVxf "-%" UVxf "\n",
t_cp, t_cp_end, r_cp, r_cp_end));

#ifdef DEBUGGING
if (DEBUG_yv_TEST) {
PerlIO_printf(Perl_debug_log,
"Processing %" UVxf "-%" UVxf " => ",
t_cp, t_cp_end);
if (r_cp == r_cp_end && r_cp == TR_UNLISTED) {
PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n");
}
else if (r_cp == r_cp_end && r_cp == TR_SPECIAL_HANDLING) {
PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n");
}
else {
PerlIO_printf(Perl_debug_log,
"%" UVxf "-%" UVxf "\n",
r_cp, r_cp_end);
}
}
#endif

/* This is the first definition for this chunk, hence is valid
* and needs to be processed. Here and in the comments below,
Expand Down Expand Up @@ -7211,8 +7258,8 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)

DEBUG_yv(PerlIO_printf(Perl_debug_log,
"Before fixing up: len=%d, i=%d\n",
(int) len, (int) i));
DEBUG_yv(invmap_dump(t_invlist, r_map));
(int) len, (int) i);
invmap_dump(t_invlist, r_map));

invlist_extend(t_invlist, len + 2);
t_array = invlist_array(t_invlist);
Expand All @@ -7234,10 +7281,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
r_map[i+2] = TR_UNLISTED;
}
DEBUG_yv(PerlIO_printf(Perl_debug_log,
"After iteration: span=%" UVuf ", t_range_count=%"
UVuf " r_range_count=%" UVuf "\n",
span, t_range_count, r_range_count));
DEBUG_yv(invmap_dump(t_invlist, r_map));
"After iteration: span=%" UVuf
", t_range_count=%" UVuf
" r_range_count=%" UVuf "\n",
span, t_range_count, r_range_count);
invmap_dump(t_invlist, r_map));
} /* End of this chunk needs to be processed */

/* Done with this chunk. */
Expand Down Expand Up @@ -7266,8 +7314,8 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)

SvREFCNT_dec(inverted_tstr);

DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n"));
DEBUG_y(invmap_dump(t_invlist, r_map));
DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n");
invmap_dump(t_invlist, r_map));

/* We now have normalized the input into an inversion map.
*
Expand Down Expand Up @@ -7417,7 +7465,16 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
: (short) TR_R_EMPTY;
#ifdef DEBUGGING
if (DEBUG_y_TEST) {
PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__);
PerlIO_printf(Perl_debug_log,
"\n%s: %d: Final generated translation table:\n %"
IVdf " means this char not involved in this transliteration\n",
__FILE__, __LINE__, TR_UNLISTED);
if (del) {
PerlIO_printf(Perl_debug_log,
" %" IVdf " means delete this char\n",
TR_SPECIAL_HANDLING);
}

for (i = 0; i < tbl->size; i++) {
if (tbl->map[i] < 0) {
PerlIO_printf(Perl_debug_log," %02x=>%d",
Expand All @@ -7431,8 +7488,32 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
PerlIO_printf(Perl_debug_log,"\n");
}
}
PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n",
(unsigned) tbl->size, tbl->map[tbl->size]);

PerlIO_printf(Perl_debug_log,
"The next (and final) byte ");
if ((UV) tbl->map[tbl->size] == TR_UNLISTED) {
PerlIO_printf(Perl_debug_log,
" indicates no other characters are involved in"
" the transliteration\n");
}
else if ((UV) tbl->map[tbl->size] == TR_SPECIAL_HANDLING) {
if (! del) {
const int size = tbl->size;
croak("panic: Unexpected value %x in [%d]",
tbl->map[size], size);
}
else {
PerlIO_printf(Perl_debug_log,
"indicates that all code points above"
" 0xFF are to be deleted\n");
}
}
else if ((UV) tbl->map[tbl->size] == TR_R_EMPTY) {
PerlIO_printf(Perl_debug_log, "is unused\n");
}
else {
PerlIO_printf(Perl_debug_log, "%x UNUSED\n", tbl->map[256]);
}
};
#endif

Expand Down
12 changes: 12 additions & 0 deletions proto.h
View file
Open in desktop

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

Loading