| 1 | /* deb.c |
| 2 | * |
| 3 | * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, |
| 4 | * 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others |
| 5 | * |
| 6 | * You may distribute under the terms of either the GNU General Public |
| 7 | * License or the Artistic License, as specified in the README file. |
| 8 | * |
| 9 | */ |
| 10 | |
| 11 | /* |
| 12 | * 'Didst thou think that the eyes of the White Tower were blind? Nay, |
| 13 | * I have seen more than thou knowest, Grey Fool.' --Denethor |
| 14 | * |
| 15 | * [p.853 of _The Lord of the Rings_, V/vii: "The Pyre of Denethor"] |
| 16 | */ |
| 17 | |
| 18 | /* |
| 19 | * This file contains various utilities for producing debugging output |
| 20 | * (mainly related to displaying the stack) |
| 21 | */ |
| 22 | |
| 23 | #include "EXTERN.h" |
| 24 | #define PERL_IN_DEB_C |
| 25 | #include "perl.h" |
| 26 | |
| 27 | #if defined(PERL_IMPLICIT_CONTEXT) |
| 28 | void |
| 29 | Perl_deb_nocontext(const char *pat, ...) |
| 30 | { |
| 31 | #ifdef DEBUGGING |
| 32 | dTHX; |
| 33 | va_list args; |
| 34 | PERL_ARGS_ASSERT_DEB_NOCONTEXT; |
| 35 | va_start(args, pat); |
| 36 | vdeb(pat, &args); |
| 37 | va_end(args); |
| 38 | #else |
| 39 | PERL_UNUSED_ARG(pat); |
| 40 | #endif /* DEBUGGING */ |
| 41 | } |
| 42 | #endif |
| 43 | |
| 44 | void |
| 45 | Perl_deb(pTHX_ const char *pat, ...) |
| 46 | { |
| 47 | va_list args; |
| 48 | PERL_ARGS_ASSERT_DEB; |
| 49 | va_start(args, pat); |
| 50 | #ifdef DEBUGGING |
| 51 | vdeb(pat, &args); |
| 52 | #else |
| 53 | PERL_UNUSED_CONTEXT; |
| 54 | #endif /* DEBUGGING */ |
| 55 | va_end(args); |
| 56 | } |
| 57 | |
| 58 | void |
| 59 | Perl_vdeb(pTHX_ const char *pat, va_list *args) |
| 60 | { |
| 61 | #ifdef DEBUGGING |
| 62 | const char* const file = PL_curcop ? OutCopFILE(PL_curcop) : "<null>"; |
| 63 | const char* const display_file = file ? file : "<free>"; |
| 64 | const long line = PL_curcop ? (long)CopLINE(PL_curcop) : 0; |
| 65 | |
| 66 | PERL_ARGS_ASSERT_VDEB; |
| 67 | |
| 68 | if (DEBUG_v_TEST) |
| 69 | PerlIO_printf(Perl_debug_log, "(%ld:%s:%ld)\t", |
| 70 | (long)PerlProc_getpid(), display_file, line); |
| 71 | else |
| 72 | PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", display_file, line); |
| 73 | (void) PerlIO_vprintf(Perl_debug_log, pat, *args); |
| 74 | #else |
| 75 | PERL_UNUSED_CONTEXT; |
| 76 | PERL_UNUSED_ARG(pat); |
| 77 | PERL_UNUSED_ARG(args); |
| 78 | #endif /* DEBUGGING */ |
| 79 | } |
| 80 | |
| 81 | I32 |
| 82 | Perl_debstackptrs(pTHX) |
| 83 | { |
| 84 | #ifdef DEBUGGING |
| 85 | PerlIO_printf(Perl_debug_log, |
| 86 | "%8" UVxf " %8" UVxf " %8" IVdf " %8" IVdf " %8" IVdf "\n", |
| 87 | PTR2UV(PL_curstack), PTR2UV(PL_stack_base), |
| 88 | (IV)*PL_markstack_ptr, (IV)(PL_stack_sp-PL_stack_base), |
| 89 | (IV)(PL_stack_max-PL_stack_base)); |
| 90 | PerlIO_printf(Perl_debug_log, |
| 91 | "%8" UVxf " %8" UVxf " %8" UVuf " %8" UVuf " %8" UVuf "\n", |
| 92 | PTR2UV(PL_mainstack), PTR2UV(AvARRAY(PL_curstack)), |
| 93 | PTR2UV(PL_mainstack), PTR2UV(AvFILLp(PL_curstack)), |
| 94 | PTR2UV(AvMAX(PL_curstack))); |
| 95 | #else |
| 96 | PERL_UNUSED_CONTEXT; |
| 97 | #endif /* DEBUGGING */ |
| 98 | return 0; |
| 99 | } |
| 100 | |
| 101 | |
| 102 | /* dump the contents of a particular stack |
| 103 | * Display stack_base[stack_min+1 .. stack_max], |
| 104 | * and display the marks whose offsets are contained in addresses |
| 105 | * PL_markstack[mark_min+1 .. mark_max] and whose values are in the range |
| 106 | * of the stack values being displayed |
| 107 | * |
| 108 | * Only displays top 30 max |
| 109 | */ |
| 110 | |
| 111 | STATIC void |
| 112 | S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max, |
| 113 | I32 mark_min, I32 mark_max) |
| 114 | { |
| 115 | #ifdef DEBUGGING |
| 116 | I32 i = stack_max - 30; |
| 117 | const I32 *markscan = PL_markstack + mark_min; |
| 118 | |
| 119 | PERL_ARGS_ASSERT_DEB_STACK_N; |
| 120 | |
| 121 | if (i < stack_min) |
| 122 | i = stack_min; |
| 123 | |
| 124 | while (++markscan <= PL_markstack + mark_max) |
| 125 | if (*markscan >= i) |
| 126 | break; |
| 127 | |
| 128 | if (i > stack_min) |
| 129 | PerlIO_printf(Perl_debug_log, "... "); |
| 130 | |
| 131 | if (stack_base[0] != &PL_sv_undef || stack_max < 0) |
| 132 | PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n"); |
| 133 | do { |
| 134 | ++i; |
| 135 | if (markscan <= PL_markstack + mark_max && *markscan < i) { |
| 136 | do { |
| 137 | ++markscan; |
| 138 | (void)PerlIO_putc(Perl_debug_log, '*'); |
| 139 | } |
| 140 | while (markscan <= PL_markstack + mark_max && *markscan < i); |
| 141 | PerlIO_printf(Perl_debug_log, " "); |
| 142 | } |
| 143 | if (i > stack_max) |
| 144 | break; |
| 145 | PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i])); |
| 146 | } |
| 147 | while (1); |
| 148 | PerlIO_printf(Perl_debug_log, "\n"); |
| 149 | #else |
| 150 | PERL_UNUSED_CONTEXT; |
| 151 | PERL_UNUSED_ARG(stack_base); |
| 152 | PERL_UNUSED_ARG(stack_min); |
| 153 | PERL_UNUSED_ARG(stack_max); |
| 154 | PERL_UNUSED_ARG(mark_min); |
| 155 | PERL_UNUSED_ARG(mark_max); |
| 156 | #endif /* DEBUGGING */ |
| 157 | } |
| 158 | |
| 159 | |
| 160 | /* dump the current stack */ |
| 161 | |
| 162 | I32 |
| 163 | Perl_debstack(pTHX) |
| 164 | { |
| 165 | #ifndef SKIP_DEBUGGING |
| 166 | if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) |
| 167 | return 0; |
| 168 | |
| 169 | PerlIO_printf(Perl_debug_log, " => "); |
| 170 | deb_stack_n(PL_stack_base, |
| 171 | 0, |
| 172 | PL_stack_sp - PL_stack_base, |
| 173 | PL_curstackinfo->si_markoff, |
| 174 | PL_markstack_ptr - PL_markstack); |
| 175 | |
| 176 | |
| 177 | #endif /* SKIP_DEBUGGING */ |
| 178 | return 0; |
| 179 | } |
| 180 | |
| 181 | |
| 182 | #ifdef DEBUGGING |
| 183 | static const char * const si_names[] = { |
| 184 | "UNKNOWN", |
| 185 | "UNDEF", |
| 186 | "MAIN", |
| 187 | "MAGIC", |
| 188 | "SORT", |
| 189 | "SIGNAL", |
| 190 | "OVERLOAD", |
| 191 | "DESTROY", |
| 192 | "WARNHOOK", |
| 193 | "DIEHOOK", |
| 194 | "REQUIRE", |
| 195 | "MULTICALL" |
| 196 | }; |
| 197 | #endif |
| 198 | |
| 199 | /* display all stacks */ |
| 200 | |
| 201 | |
| 202 | void |
| 203 | Perl_deb_stack_all(pTHX) |
| 204 | { |
| 205 | #ifdef DEBUGGING |
| 206 | I32 si_ix; |
| 207 | const PERL_SI *si; |
| 208 | |
| 209 | /* rewind to start of chain */ |
| 210 | si = PL_curstackinfo; |
| 211 | while (si->si_prev) |
| 212 | si = si->si_prev; |
| 213 | |
| 214 | si_ix=0; |
| 215 | for (;;) |
| 216 | { |
| 217 | const size_t si_name_ix = si->si_type+1; /* -1 is a valid index */ |
| 218 | const char * const si_name = |
| 219 | si_name_ix < C_ARRAY_LENGTH(si_names) ? |
| 220 | si_names[si_name_ix] : "????"; |
| 221 | I32 ix; |
| 222 | PerlIO_printf(Perl_debug_log, "STACK %" IVdf ": %s\n", |
| 223 | (IV)si_ix, si_name); |
| 224 | |
| 225 | for (ix=0; ix<=si->si_cxix; ix++) { |
| 226 | |
| 227 | const PERL_CONTEXT * const cx = &(si->si_cxstack[ix]); |
| 228 | PerlIO_printf(Perl_debug_log, |
| 229 | " CX %" IVdf ": %-6s => ", |
| 230 | (IV)ix, PL_block_type[CxTYPE(cx)] |
| 231 | ); |
| 232 | /* substitution contexts don't save stack pointers etc) */ |
| 233 | if (CxTYPE(cx) == CXt_SUBST) |
| 234 | PerlIO_printf(Perl_debug_log, "\n"); |
| 235 | else { |
| 236 | |
| 237 | /* Find the current context's stack range by searching |
| 238 | * forward for any higher contexts using this stack; failing |
| 239 | * that, it will be equal to the size of the stack for old |
| 240 | * stacks, or PL_stack_sp for the current stack |
| 241 | */ |
| 242 | |
| 243 | I32 i, stack_min, stack_max, mark_min, mark_max; |
| 244 | const PERL_CONTEXT *cx_n = NULL; |
| 245 | const PERL_SI *si_n; |
| 246 | |
| 247 | /* there's a separate argument stack per SI, so only |
| 248 | * search this one */ |
| 249 | |
| 250 | for (i=ix+1; i<=si->si_cxix; i++) { |
| 251 | const PERL_CONTEXT *this_cx = &(si->si_cxstack[i]); |
| 252 | if (CxTYPE(this_cx) == CXt_SUBST) |
| 253 | continue; |
| 254 | cx_n = this_cx; |
| 255 | break; |
| 256 | } |
| 257 | |
| 258 | stack_min = cx->blk_oldsp; |
| 259 | |
| 260 | if (cx_n) { |
| 261 | stack_max = cx_n->blk_oldsp; |
| 262 | } |
| 263 | else if (si == PL_curstackinfo) { |
| 264 | stack_max = PL_stack_sp - AvARRAY(si->si_stack); |
| 265 | } |
| 266 | else { |
| 267 | stack_max = AvFILLp(si->si_stack); |
| 268 | } |
| 269 | |
| 270 | /* for the markstack, there's only one stack shared |
| 271 | * between all SIs */ |
| 272 | |
| 273 | si_n = si; |
| 274 | i = ix; |
| 275 | cx_n = NULL; |
| 276 | for (;;) { |
| 277 | i++; |
| 278 | if (i > si_n->si_cxix) { |
| 279 | if (si_n == PL_curstackinfo) |
| 280 | break; |
| 281 | else { |
| 282 | si_n = si_n->si_next; |
| 283 | i = 0; |
| 284 | } |
| 285 | } |
| 286 | if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST) |
| 287 | continue; |
| 288 | cx_n = &(si_n->si_cxstack[i]); |
| 289 | break; |
| 290 | } |
| 291 | |
| 292 | mark_min = cx->blk_oldmarksp; |
| 293 | if (cx_n) { |
| 294 | mark_max = cx_n->blk_oldmarksp; |
| 295 | } |
| 296 | else { |
| 297 | mark_max = PL_markstack_ptr - PL_markstack; |
| 298 | } |
| 299 | |
| 300 | deb_stack_n(AvARRAY(si->si_stack), |
| 301 | stack_min, stack_max, mark_min, mark_max); |
| 302 | |
| 303 | if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB |
| 304 | || CxTYPE(cx) == CXt_FORMAT) |
| 305 | { |
| 306 | const OP * const retop = cx->blk_sub.retop; |
| 307 | |
| 308 | PerlIO_printf(Perl_debug_log, " retop=%s\n", |
| 309 | retop ? OP_NAME(retop) : "(null)" |
| 310 | ); |
| 311 | } |
| 312 | } |
| 313 | } /* next context */ |
| 314 | |
| 315 | |
| 316 | if (si == PL_curstackinfo) |
| 317 | break; |
| 318 | si = si->si_next; |
| 319 | si_ix++; |
| 320 | if (!si) |
| 321 | break; /* shouldn't happen, but just in case.. */ |
| 322 | } /* next stackinfo */ |
| 323 | |
| 324 | PerlIO_printf(Perl_debug_log, "\n"); |
| 325 | #else |
| 326 | PERL_UNUSED_CONTEXT; |
| 327 | #endif /* DEBUGGING */ |
| 328 | } |
| 329 | |
| 330 | /* |
| 331 | * ex: set ts=8 sts=4 sw=4 et: |
| 332 | */ |