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 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 = 221 si_name_ix < C_ARRAY_LENGTH(si_names) ? 222 si_names[si_name_ix] : "????"; 223 I32 ix; 224 PerlIO_printf(Perl_debug_log, "STACK %"IVdf": %s\n", 225 (IV)si_ix, si_name); 226 227 for (ix=0; ix<=si->si_cxix; ix++) { 228 229 const PERL_CONTEXT * const cx = &(si->si_cxstack[ix]); 230 PerlIO_printf(Perl_debug_log, 231 " CX %"IVdf": %-6s => ", 232 (IV)ix, PL_block_type[CxTYPE(cx)] 233 ); 234 /* substitution contexts don't save stack pointers etc) */ 235 if (CxTYPE(cx) == CXt_SUBST) 236 PerlIO_printf(Perl_debug_log, "\n"); 237 else { 238 239 /* Find the current context's stack range by searching 240 * forward for any higher contexts using this stack; failing 241 * that, it will be equal to the size of the stack for old 242 * stacks, or PL_stack_sp for the current stack 243 */ 244 245 I32 i, stack_min, stack_max, mark_min, mark_max; 246 const PERL_CONTEXT *cx_n = NULL; 247 const PERL_SI *si_n; 248 249 /* there's a separate stack per SI, so only search 250 * this one */ 251 252 for (i=ix+1; i<=si->si_cxix; i++) { 253 if (CxTYPE(cx) == CXt_SUBST) 254 continue; 255 cx_n = &(si->si_cxstack[i]); 256 break; 257 } 258 259 stack_min = cx->blk_oldsp; 260 261 if (cx_n) { 262 stack_max = cx_n->blk_oldsp; 263 } 264 else if (si == PL_curstackinfo) { 265 stack_max = PL_stack_sp - AvARRAY(si->si_stack); 266 } 267 else { 268 stack_max = AvFILLp(si->si_stack); 269 } 270 271 /* for the other stack types, there's only one stack 272 * shared between all SIs */ 273 274 si_n = si; 275 i = ix; 276 cx_n = NULL; 277 for (;;) { 278 i++; 279 if (i > si_n->si_cxix) { 280 if (si_n == PL_curstackinfo) 281 break; 282 else { 283 si_n = si_n->si_next; 284 i = 0; 285 } 286 } 287 if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST) 288 continue; 289 cx_n = &(si_n->si_cxstack[i]); 290 break; 291 } 292 293 mark_min = cx->blk_oldmarksp; 294 if (cx_n) { 295 mark_max = cx_n->blk_oldmarksp; 296 } 297 else { 298 mark_max = PL_markstack_ptr - PL_markstack; 299 } 300 301 deb_stack_n(AvARRAY(si->si_stack), 302 stack_min, stack_max, mark_min, mark_max); 303 304 if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB 305 || CxTYPE(cx) == CXt_FORMAT) 306 { 307 const OP * const retop = cx->blk_sub.retop; 308 309 PerlIO_printf(Perl_debug_log, " retop=%s\n", 310 retop ? OP_NAME(retop) : "(null)" 311 ); 312 } 313 } 314 } /* next context */ 315 316 317 if (si == PL_curstackinfo) 318 break; 319 si = si->si_next; 320 si_ix++; 321 if (!si) 322 break; /* shouldn't happen, but just in case.. */ 323 } /* next stackinfo */ 324 325 PerlIO_printf(Perl_debug_log, "\n"); 326 #else 327 PERL_UNUSED_CONTEXT; 328 #endif /* DEBUGGING */ 329 } 330 331 /* 332 * Local variables: 333 * c-indentation-style: bsd 334 * c-basic-offset: 4 335 * indent-tabs-mode: nil 336 * End: 337 * 338 * ex: set ts=8 sts=4 sw=4 et: 339 */ 340