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 dVAR; 63 const char* const file = PL_curcop ? OutCopFILE(PL_curcop) : "<null>"; 64 const char* const display_file = file ? file : "<free>"; 65 const long line = PL_curcop ? (long)CopLINE(PL_curcop) : 0; 66 67 PERL_ARGS_ASSERT_VDEB; 68 69 if (DEBUG_v_TEST) 70 PerlIO_printf(Perl_debug_log, "(%ld:%s:%ld)\t", 71 (long)PerlProc_getpid(), display_file, line); 72 else 73 PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", display_file, line); 74 (void) PerlIO_vprintf(Perl_debug_log, pat, *args); 75 #else 76 PERL_UNUSED_CONTEXT; 77 PERL_UNUSED_ARG(pat); 78 PERL_UNUSED_ARG(args); 79 #endif /* DEBUGGING */ 80 } 81 82 I32 83 Perl_debstackptrs(pTHX) 84 { 85 #ifdef DEBUGGING 86 dVAR; 87 PerlIO_printf(Perl_debug_log, 88 "%8"UVxf" %8"UVxf" %8"IVdf" %8"IVdf" %8"IVdf"\n", 89 PTR2UV(PL_curstack), PTR2UV(PL_stack_base), 90 (IV)*PL_markstack_ptr, (IV)(PL_stack_sp-PL_stack_base), 91 (IV)(PL_stack_max-PL_stack_base)); 92 PerlIO_printf(Perl_debug_log, 93 "%8"UVxf" %8"UVxf" %8"UVuf" %8"UVuf" %8"UVuf"\n", 94 PTR2UV(PL_mainstack), PTR2UV(AvARRAY(PL_curstack)), 95 PTR2UV(PL_mainstack), PTR2UV(AvFILLp(PL_curstack)), 96 PTR2UV(AvMAX(PL_curstack))); 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 dVAR; 117 register I32 i = stack_max - 30; 118 const I32 *markscan = PL_markstack + mark_min; 119 120 PERL_ARGS_ASSERT_DEB_STACK_N; 121 122 if (i < stack_min) 123 i = stack_min; 124 125 while (++markscan <= PL_markstack + mark_max) 126 if (*markscan >= i) 127 break; 128 129 if (i > stack_min) 130 PerlIO_printf(Perl_debug_log, "... "); 131 132 if (stack_base[0] != &PL_sv_undef || stack_max < 0) 133 PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n"); 134 do { 135 ++i; 136 if (markscan <= PL_markstack + mark_max && *markscan < i) { 137 do { 138 ++markscan; 139 PerlIO_putc(Perl_debug_log, '*'); 140 } 141 while (markscan <= PL_markstack + mark_max && *markscan < i); 142 PerlIO_printf(Perl_debug_log, " "); 143 } 144 if (i > stack_max) 145 break; 146 PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i])); 147 } 148 while (1); 149 PerlIO_printf(Perl_debug_log, "\n"); 150 #else 151 PERL_UNUSED_CONTEXT; 152 PERL_UNUSED_ARG(stack_base); 153 PERL_UNUSED_ARG(stack_min); 154 PERL_UNUSED_ARG(stack_max); 155 PERL_UNUSED_ARG(mark_min); 156 PERL_UNUSED_ARG(mark_max); 157 #endif /* DEBUGGING */ 158 } 159 160 161 /* dump the current stack */ 162 163 I32 164 Perl_debstack(pTHX) 165 { 166 #ifndef SKIP_DEBUGGING 167 dVAR; 168 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) 169 return 0; 170 171 PerlIO_printf(Perl_debug_log, " => "); 172 deb_stack_n(PL_stack_base, 173 0, 174 PL_stack_sp - PL_stack_base, 175 PL_curstackinfo->si_markoff, 176 PL_markstack_ptr - PL_markstack); 177 178 179 #endif /* SKIP_DEBUGGING */ 180 return 0; 181 } 182 183 184 #ifdef DEBUGGING 185 static const char * const si_names[] = { 186 "UNKNOWN", 187 "UNDEF", 188 "MAIN", 189 "MAGIC", 190 "SORT", 191 "SIGNAL", 192 "OVERLOAD", 193 "DESTROY", 194 "WARNHOOK", 195 "DIEHOOK", 196 "REQUIRE" 197 }; 198 #endif 199 200 /* display all stacks */ 201 202 203 void 204 Perl_deb_stack_all(pTHX) 205 { 206 #ifdef DEBUGGING 207 dVAR; 208 I32 si_ix; 209 const PERL_SI *si; 210 211 /* rewind to start of chain */ 212 si = PL_curstackinfo; 213 while (si->si_prev) 214 si = si->si_prev; 215 216 si_ix=0; 217 for (;;) 218 { 219 const size_t si_name_ix = si->si_type+1; /* -1 is a valid index */ 220 const char * const si_name = (si_name_ix >= sizeof(si_names)) ? "????" : 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 stack per SI, so only search 248 * this one */ 249 250 for (i=ix+1; i<=si->si_cxix; i++) { 251 if (CxTYPE(cx) == CXt_SUBST) 252 continue; 253 cx_n = &(si->si_cxstack[i]); 254 break; 255 } 256 257 stack_min = cx->blk_oldsp; 258 259 if (cx_n) { 260 stack_max = cx_n->blk_oldsp; 261 } 262 else if (si == PL_curstackinfo) { 263 stack_max = PL_stack_sp - AvARRAY(si->si_stack); 264 } 265 else { 266 stack_max = AvFILLp(si->si_stack); 267 } 268 269 /* for the other stack types, there's only one stack 270 * shared between all SIs */ 271 272 si_n = si; 273 i = ix; 274 cx_n = NULL; 275 for (;;) { 276 i++; 277 if (i > si_n->si_cxix) { 278 if (si_n == PL_curstackinfo) 279 break; 280 else { 281 si_n = si_n->si_next; 282 i = 0; 283 } 284 } 285 if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST) 286 continue; 287 cx_n = &(si_n->si_cxstack[i]); 288 break; 289 } 290 291 mark_min = cx->blk_oldmarksp; 292 if (cx_n) { 293 mark_max = cx_n->blk_oldmarksp; 294 } 295 else { 296 mark_max = PL_markstack_ptr - PL_markstack; 297 } 298 299 deb_stack_n(AvARRAY(si->si_stack), 300 stack_min, stack_max, mark_min, mark_max); 301 302 if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB 303 || CxTYPE(cx) == CXt_FORMAT) 304 { 305 const OP * const retop = (CxTYPE(cx) == CXt_EVAL) 306 ? cx->blk_eval.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 * Local variables: 332 * c-indentation-style: bsd 333 * c-basic-offset: 4 334 * indent-tabs-mode: t 335 * End: 336 * 337 * ex: set ts=8 sts=4 sw=4 noet: 338 */ 339