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