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 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 = cx->blk_sub.retop; 306 307 PerlIO_printf(Perl_debug_log, " retop=%s\n", 308 retop ? OP_NAME(retop) : "(null)" 309 ); 310 } 311 } 312 } /* next context */ 313 314 315 if (si == PL_curstackinfo) 316 break; 317 si = si->si_next; 318 si_ix++; 319 if (!si) 320 break; /* shouldn't happen, but just in case.. */ 321 } /* next stackinfo */ 322 323 PerlIO_printf(Perl_debug_log, "\n"); 324 #else 325 PERL_UNUSED_CONTEXT; 326 #endif /* DEBUGGING */ 327 } 328 329 /* 330 * ex: set ts=8 sts=4 sw=4 et: 331 */ 332