[PATCH] add verbose stack display option, -Dvs
Dave Mitchell
but which got ignored due to the code freeze.
This patch:
(a) adds a new generic -D flag: 'v', which means
"make the other debug flags potentially behave more verbosely";
(b) makes the 's' flag dump all the stacks + context for each executed op.
eg the one-line output per op of
perl -Ds ...
=> * PV("foo"\0) * PV("bar"\0)
becomes the multi-line
perl -Dvs ...
STACK 0: MAIN
CX 0: BLOCK => * IV(5) IV(6)
retop=const
CX 1: SUB => * IV(1) IV(2) IV(2)
STACK 1: SORT
CX 0: SUB => * PV("foo"\0)
retop=(null)
CX 1: EVAL => * PV("bar"\0)
Kind of educational, if nothing else.
(needs a make regen_headers after application)
Dave.
--
Lady Nancy Astor: If you were my husband, I would flavour your coffee
with poison.
Churchill: Madam - if I were your husband, I would drink it.
#
# To apply this patch:
# STEP 1: Chdir to the source directory.
# STEP 2: Run the 'applypatch' program with this patch file as input.
#
# If you do not have 'applypatch', it is part of the 'makepatch' package
# that you can fetch from the Comprehensive Perl Archive Network:
# http://www.perl.com/CPAN/authors/Johan_Vromans/makepatch-x.y.tar.gz
# In the above URL, 'x' should be 2 or higher.
#
# To apply this patch without the use of 'applypatch':
# STEP 1: Chdir to the source directory.
# STEP 2: Run the 'patch' program with this file as input.
#
#### End of Preamble ####
#### Patch data follows ####
diff -u '17675.ORIG/deb.c' '17675v/deb.c'
Index: ./deb.c
--- ./deb.c Sun Aug 4 15:49:34 2002
+++ ./deb.c Mon Aug 5 00:38:59 2002
@@ -78,49 +78,226 @@
return 0;
}
-I32
-Perl_debstack(pTHX)
-{
-#ifndef SKIP_DEBUGGING
- I32 top = PL_stack_sp - PL_stack_base;
- register I32 i = top - 30;
- I32 *markscan = PL_markstack + PL_curstackinfo->si_markoff;
- if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
- return 0;
+/* dump the contents of a particular stack
+ * Display stack_base[stack_min+1 .. stack_max],
+ * and display the marks whose offsets are contained in addresses
+ * PL_markstack[mark_min+1 .. mark_max] and whose values are in the range
+ * of the stack values being displayed
+ *
+ * Only displays top 30 max
+ */
- if (i < 0)
- i = 0;
+STATIC void
+S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max,
+ I32 mark_min, I32 mark_max)
+{
+#ifdef DEBUGGING
+ register I32 i = stack_max - 30;
+ I32 *markscan = PL_markstack + mark_min;
+ if (i < stack_min)
+ i = stack_min;
- while (++markscan <= PL_markstack_ptr)
+ while (++markscan <= PL_markstack + mark_max)
if (*markscan >= i)
break;
-#ifdef USE_5005THREADS
- PerlIO_printf(Perl_debug_log,
- i ? "0x%"UVxf" => ... " : "0x%lx => ",
- PTR2UV(thr));
-#else
- PerlIO_printf(Perl_debug_log, i ? " => ... " : " => ");
-#endif /* USE_5005THREADS */
- if (PL_stack_base[0] != &PL_sv_undef || PL_stack_sp < PL_stack_base)
+ if (i > stack_min)
+ PerlIO_printf(Perl_debug_log, "... ");
+
+ if (stack_base[0] != &PL_sv_undef || stack_max < 0)
PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
do {
++i;
- if (markscan <= PL_markstack_ptr && *markscan < i) {
+ if (markscan <= PL_markstack + mark_max && *markscan < i) {
do {
++markscan;
PerlIO_putc(Perl_debug_log, '*');
}
- while (markscan <= PL_markstack_ptr && *markscan < i);
+ while (markscan <= PL_markstack + mark_max && *markscan < i);
PerlIO_printf(Perl_debug_log, " ");
}
- if (i > top)
+ if (i > stack_max)
break;
- PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(PL_stack_base[i]));
+ PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i]));
}
while (1);
PerlIO_printf(Perl_debug_log, "\n");
+#endif /* DEBUGGING */
+}
+
+
+/* dump the current stack */
+
+I32
+Perl_debstack(pTHX)
+{
+#ifndef SKIP_DEBUGGING
+ if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
+ return 0;
+
+ PerlIO_printf(Perl_debug_log, " => ");
+ deb_stack_n(PL_stack_base,
+ 0,
+ PL_stack_sp - PL_stack_base,
+ PL_curstackinfo->si_markoff,
+ PL_markstack_ptr - PL_markstack);
+
+
#endif /* SKIP_DEBUGGING */
return 0;
}
+
+
+#ifdef DEBUGGING
+static char * si_names[] = {
+ "UNKNOWN",
+ "UNDEF",
+ "MAIN",
+ "MAGIC",
+ "SORT",
+ "SIGNAL",
+ "OVERLOAD",
+ "DESTROY",
+ "WARNHOOK",
+ "DIEHOOK",
+ "REQUIRE"
+};
+#endif
+
+/* display all stacks */
+
+
+void
+Perl_deb_stack_all(pTHX)
+{
+#ifdef DEBUGGING
+ I32 ix, si_ix;
+ PERL_SI *si;
+ PERL_CONTEXT *cx;
+
+ /* rewind to start of chain */
+ si = PL_curstackinfo;
+ while (si->si_prev)
+ si = si->si_prev;
+
+ si_ix=0;
+ for (;;)
+ {
+ char *si_name;
+ int si_name_ix = si->si_type+1; /* -1 is a valid index */
+ if (si_name_ix>= sizeof(si_names))
+ si_name = "????";
+ else
+ si_name = si_names[si_name_ix];
+ PerlIO_printf(Perl_debug_log, "STACK %"IVdf": %s\n",
+ si_ix, si_name);
+
+ for (ix=0; ix<=si->si_cxix; ix++) {
+
+ cx = &(si->si_cxstack[ix]);
+ PerlIO_printf(Perl_debug_log,
+ " CX %"IVdf": %-6s => ",
+ ix, PL_block_type[CxTYPE(cx)]
+ );
+ /* substitution contexts don't save stack pointers etc) */
+ if (CxTYPE(cx) == CXt_SUBST)
+ PerlIO_printf(Perl_debug_log, "\n");
+ else {
+
+ /* Find the the current context's stack range by searching
+ * forward for any higher contexts using this stack; failing
+ * that, it will be equal to the size of the stack for old
+ * stacks, or PL_stack_sp for the current stack
+ */
+
+ I32 i, stack_min, stack_max, mark_min, mark_max;
+ I32 ret_min, ret_max;
+ PERL_CONTEXT *cx_n;
+ PERL_SI *si_n;
+
+ cx_n = Null(PERL_CONTEXT*);
+
+ /* there's a separate stack per SI, so only search
+ * this one */
+
+ for (i=ix+1; i<=si->si_cxix; i++) {
+ if (CxTYPE(cx) == CXt_SUBST)
+ continue;
+ cx_n = &(si->si_cxstack[i]);
+ break;
+ }
+
+ stack_min = cx->blk_oldsp;
+
+ if (cx_n) {
+ stack_max = cx_n->blk_oldsp;
+ }
+ else if (si == PL_curstackinfo) {
+ stack_max = PL_stack_sp - AvARRAY(si->si_stack);
+ }
+ else {
+ stack_max = AvFILLp(si->si_stack);
+ }
+
+ /* for the other stack types, there's only one stack
+ * shared between all SIs */
+
+ si_n = si;
+ i = ix;
+ cx_n = Null(PERL_CONTEXT*);
+ for (;;) {
+ i++;
+ if (i > si_n->si_cxix) {
+ if (si_n == PL_curstackinfo)
+ break;
+ else {
+ si_n = si_n->si_next;
+ i = 0;
+ }
+ }
+ if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST)
+ continue;
+ cx_n = &(si_n->si_cxstack[i]);
+ break;
+ }
+
+ mark_min = cx->blk_oldmarksp;
+ ret_min = cx->blk_oldretsp;
+ if (cx_n) {
+ mark_max = cx_n->blk_oldmarksp;
+ ret_max = cx_n->blk_oldretsp;
+ }
+ else {
+ mark_max = PL_markstack_ptr - PL_markstack;
+ ret_max = PL_retstack_ix;
+ }
+
+ deb_stack_n(AvARRAY(si->si_stack),
+ stack_min, stack_max, mark_min, mark_max);
+
+ if (ret_max > ret_min) {
+ PerlIO_printf(Perl_debug_log, " retop=%s\n",
+ PL_retstack[ret_min]
+ ? OP_NAME(PL_retstack[ret_min])
+ : "(null)"
+ );
+ }
+
+ }
+ } /* next context */
+
+
+ if (si == PL_curstackinfo)
+ break;
+ si = si->si_next;
+ si_ix++;
+ if (!si)
+ break; /* shouldn't happen, but just in case.. */
+ } /* next stackinfo */
+
+ PerlIO_printf(Perl_debug_log, "\n");
+#endif /* DEBUGGING */
+}
+
+
diff -u '17675.ORIG/dump.c' '17675v/dump.c'
Index: ./dump.c
--- ./dump.c Sun Aug 4 15:49:34 2002
+++ ./dump.c Sun Aug 4 16:22:35 2002
@@ -1391,7 +1391,16 @@
"WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
PTR2UV(*PL_watchaddr));
- if (DEBUG_s_TEST_) debstack();
+ if (DEBUG_s_TEST_) {
+ if (DEBUG_v_TEST_) {
+ PerlIO_printf(Perl_debug_log, "\n");
+ deb_stack_all();
+ }
+ else
+ debstack();
+ }
+
+
if (DEBUG_t_TEST_) debop(PL_op);
if (DEBUG_P_TEST_) debprof(PL_op);
}
diff -u '17675.ORIG/embed.fnc' '17675v/embed.fnc'
Index: ./embed.fnc
--- ./embed.fnc Sun Aug 4 15:49:51 2002
+++ ./embed.fnc Sun Aug 4 22:58:23 2002
@@ -1359,5 +1359,12 @@
Ap |PerlIO *|PerlIO_stderr
#endif /* PERLIO_LAYERS */
+p |void |deb_stack_all
+#ifdef PERL_IN_DEB_C
+s |void |deb_stack_n |SV** stack_base, I32 stack_min, \
+ I32 stack_max, I32 mark_min, I32 mark_max
+#endif
+
+
END_EXTERN_C
diff -u '17675.ORIG/perl.c' '17675v/perl.c'
Index: ./perl.c
--- ./perl.c Sun Aug 4 15:49:34 2002
+++ ./perl.c Sun Aug 4 16:26:48 2002
@@ -2338,7 +2338,7 @@
forbid_setid("-D");
if (isALPHA(s[1])) {
/* if adding extra options, remember to update DEBUG_MASK */
- static char debopts[] = "psltocPmfrxuLHXDSTRJ";
+ static char debopts[] = "psltocPmfrxuLHXDSTRJv";
char *d;
for (s++; *s && (d = strchr(debopts,*s)); s++)
diff -u '17675.ORIG/perl.h' '17675v/perl.h'
Index: ./perl.h
--- ./perl.h Sun Aug 4 15:49:34 2002
+++ ./perl.h Sun Aug 4 16:40:10 2002
@@ -2423,7 +2423,8 @@
#define DEBUG_T_FLAG 0x00020000 /* 131072 */
#define DEBUG_R_FLAG 0x00040000 /* 262144 */
#define DEBUG_J_FLAG 0x00080000 /* 524288 */
-#define DEBUG_MASK 0x000FFFFF /* mask of all the standard flags */
+#define DEBUG_v_FLAG 0x00100000 /*1048576 */
+#define DEBUG_MASK 0x001FFFFF /* mask of all the standard flags */
#define DEBUG_DB_RECURSE_FLAG 0x40000000
#define DEBUG_TOP_FLAG 0x80000000 /* XXX what's this for ??? Signal
@@ -2449,6 +2450,7 @@
# define DEBUG_T_TEST_ (PL_debug & DEBUG_T_FLAG)
# define DEBUG_R_TEST_ (PL_debug & DEBUG_R_FLAG)
# define DEBUG_J_TEST_ (PL_debug & DEBUG_J_FLAG)
+# define DEBUG_v_TEST_ (PL_debug & DEBUG_v_FLAG)
#ifdef DEBUGGING
@@ -2475,6 +2477,7 @@
# define DEBUG_T_TEST DEBUG_T_TEST_
# define DEBUG_R_TEST DEBUG_R_TEST_
# define DEBUG_J_TEST DEBUG_J_TEST_
+# define DEBUG_v_TEST DEBUG_v_TEST_
# define DEB(a) a
# define DEBUG(a) if (PL_debug) a
@@ -2515,6 +2518,7 @@
# define DEBUG_T(a) DEBUG__(DEBUG_T_TEST, a)
# define DEBUG_R(a) DEBUG__(DEBUG_R_TEST, a)
+# define DEBUG_v(a) DEBUG__(DEBUG_v_TEST, a)
#else /* DEBUGGING */
@@ -2538,6 +2542,7 @@
# define DEBUG_T_TEST (0)
# define DEBUG_R_TEST (0)
# define DEBUG_J_TEST (0)
+# define DEBUG_v_TEST (0)
# define DEB(a)
# define DEBUG(a)
@@ -2560,6 +2565,7 @@
# define DEBUG_S(a)
# define DEBUG_T(a)
# define DEBUG_R(a)
+# define DEBUG_v(a)
#endif /* DEBUGGING */
diff -u '17675.ORIG/pod/perlrun.pod' '17675v/pod/perlrun.pod'
Index: ./pod/perlrun.pod
--- ./pod/perlrun.pod Sun Aug 4 15:49:46 2002
+++ ./pod/perlrun.pod Sun Aug 4 16:41:42 2002
@@ -309,6 +309,7 @@
1 p Tokenizing and parsing
2 s Stack snapshots
+ with v, displays all stacks
4 l Context (loop) stack processing
8 t Trace execution
16 o Method and overloading resolution
@@ -327,6 +328,7 @@
131072 T Tokenising
262144 R Include reference counts of dumped variables (eg when using -Ds)
524288 J Do not s,t,P-debug (Jump over) opcodes within package DB
+ 1048576 v Verbose: use in conjunction with other flags
All these flags require B<-DDEBUGGING> when you compile the Perl
executable (but see L<Devel::Peek>, L<re> which may change this).
#### End of Patch data ####
#### ApplyPatch data follows ####
# Data version : 1.0
# Date generated : Mon Aug 5 00:39:29 2002
# Generated by : makepatch 2.00_05
# Recurse directories : Yes
# Excluded files : keywords\.h|warnings\.h|regnodes\.h|perlapi\.c|perlapi\.h|global\.sym|embedvar\.h|embed\.h|pod\/perlapi\.pod|proto\.h
# v 'patchlevel.h' 3282 1028472612 33188
# p 'deb.c' 3034 1028504339 0100644
# p 'dump.c' 45713 1028474555 0100644
# p 'embed.fnc' 49865 1028498303 0100644
# p 'perl.c' 107515 1028474808 0100644
# p 'perl.h' 118851 1028475610 0100644
# p 'pod/perlrun.pod' 38383 1028475702 0100644
#### End of ApplyPatch data ####
#### End of Patch kit [created: Mon Aug 5 00:39:29 2002] ####
#### Patch checksum: 400 10647 44428 ####
#### Checksum: 417 11270 30439 ####
h...@crypt.org
:This patch:
:(a) adds a new generic -D flag: 'v', which means
: "make the other debug flags potentially behave more verbosely";
:(b) makes the 's' flag dump all the stacks + context for each executed op.
Thanks, applied as #17718.
Hugo