From: Dave Mitchell Date: Mon, 5 Aug 2002 00:55:33 +0000 (+0100) Subject: add verbose stack display option, -Dvs X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d672126634c5e568812ed35d4c8ea53a9a55ee4c;p=p5sagit%2Fp5-mst-13.2.git add verbose stack display option, -Dvs Message-id: <20020805005533.B26111@fdgroup.com> p4raw-id: //depot/perl@17718 --- diff --git a/deb.c b/deb.c index 6a5a21c..37b42e1 100644 --- a/deb.c +++ b/deb.c @@ -78,49 +78,226 @@ Perl_debstackptrs(pTHX) 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 --git a/dump.c b/dump.c index 7828e94..83fd09e 100644 --- a/dump.c +++ b/dump.c @@ -1391,7 +1391,16 @@ Perl_runops_debug(pTHX) "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 --git a/embed.fnc b/embed.fnc index a2c83b5..af9961e 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1359,5 +1359,12 @@ Ap |PerlIO *|PerlIO_stdout 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 --git a/embed.h b/embed.h index 03b64f5..d6c74f5 100644 --- a/embed.h +++ b/embed.h @@ -1220,6 +1220,10 @@ #define PerlIO_stdout Perl_PerlIO_stdout #define PerlIO_stderr Perl_PerlIO_stderr #endif /* PERLIO_LAYERS */ +#define deb_stack_all Perl_deb_stack_all +#ifdef PERL_IN_DEB_C +#define deb_stack_n S_deb_stack_n +#endif #define ck_anoncode Perl_ck_anoncode #define ck_bitop Perl_ck_bitop #define ck_concat Perl_ck_concat @@ -2780,6 +2784,10 @@ #define PerlIO_stdout() Perl_PerlIO_stdout(aTHX) #define PerlIO_stderr() Perl_PerlIO_stderr(aTHX) #endif /* PERLIO_LAYERS */ +#define deb_stack_all() Perl_deb_stack_all(aTHX) +#ifdef PERL_IN_DEB_C +#define deb_stack_n(a) S_deb_stack_n(aTHX_ a) +#endif #define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a) #define ck_bitop(a) Perl_ck_bitop(aTHX_ a) #define ck_concat(a) Perl_ck_concat(aTHX_ a) diff --git a/perl.c b/perl.c index 3647708..224cc9c 100644 --- a/perl.c +++ b/perl.c @@ -2338,7 +2338,7 @@ Perl_moreswitches(pTHX_ char *s) 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 --git a/perl.h b/perl.h index dbc3758..5c13a7d 100644 --- a/perl.h +++ b/perl.h @@ -2429,7 +2429,8 @@ Gid_t getegid (void); #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 @@ -2455,6 +2456,7 @@ Gid_t getegid (void); # 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 @@ -2481,6 +2483,7 @@ Gid_t getegid (void); # 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 @@ -2521,6 +2524,7 @@ Gid_t getegid (void); # 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 */ @@ -2544,6 +2548,7 @@ Gid_t getegid (void); # 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) @@ -2566,6 +2571,7 @@ Gid_t getegid (void); # define DEBUG_S(a) # define DEBUG_T(a) # define DEBUG_R(a) +# define DEBUG_v(a) #endif /* DEBUGGING */ diff --git a/pod/perlapi.pod b/pod/perlapi.pod index 0842096..585c1ac 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -2964,21 +2964,21 @@ Like C, but converts sv to utf8 first if necessary. =for hackers Found in file sv.h -=item SvPVx +=item SvPVX -A version of C which guarantees to evaluate sv only once. +Returns a pointer to the physical string in the SV. The SV must contain a +string. - char* SvPVx(SV* sv, STRLEN len) + char* SvPVX(SV* sv) =for hackers Found in file sv.h -=item SvPVX +=item SvPVx -Returns a pointer to the physical string in the SV. The SV must contain a -string. +A version of C which guarantees to evaluate sv only once. - char* SvPVX(SV* sv) + char* SvPVx(SV* sv, STRLEN len) =for hackers Found in file sv.h @@ -3217,22 +3217,22 @@ for a version which guarantees to evaluate sv only once. =for hackers Found in file sv.h -=item SvUVX +=item SvUVx -Returns the raw value in the SV's UV slot, without checks or conversions. -Only use when you are sure SvIOK is true. See also C. +Coerces the given SV to an unsigned integer and returns it. Guarantees to +evaluate sv only once. Use the more efficient C otherwise. - UV SvUVX(SV* sv) + UV SvUVx(SV* sv) =for hackers Found in file sv.h -=item SvUVx +=item SvUVX -Coerces the given SV to an unsigned integer and returns it. Guarantees to -evaluate sv only once. Use the more efficient C otherwise. +Returns the raw value in the SV's UV slot, without checks or conversions. +Only use when you are sure SvIOK is true. See also C. - UV SvUVx(SV* sv) + UV SvUVX(SV* sv) =for hackers Found in file sv.h diff --git a/pod/perlrun.pod b/pod/perlrun.pod index 4f9afdf..3c1f159 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -309,6 +309,7 @@ B<-D14> is equivalent to B<-Dtls>): 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 @@ B<-D14> is equivalent to B<-Dtls>): 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, L which may change this). diff --git a/proto.h b/proto.h index 666caa1..9dabf81 100644 --- a/proto.h +++ b/proto.h @@ -1388,5 +1388,11 @@ PERL_CALLCONV PerlIO * Perl_PerlIO_stdout(pTHX); PERL_CALLCONV PerlIO * Perl_PerlIO_stderr(pTHX); #endif /* PERLIO_LAYERS */ +PERL_CALLCONV void Perl_deb_stack_all(pTHX); +#ifdef PERL_IN_DEB_C +STATIC void S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max, I32 mark_min, I32 mark_max); +#endif + + END_EXTERN_C