Commit | Line | Data |
a0d0e21e |
1 | /* deb.c |
79072805 |
2 | * |
4bb101f2 |
3 | * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1998, 1999, |
54ca4ee7 |
4 | * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others |
79072805 |
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 | * |
a0d0e21e |
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 |
79072805 |
14 | */ |
15 | |
166f8a29 |
16 | /* |
61296642 |
17 | * This file contains various utilities for producing debugging output |
18 | * (mainly related to displaying the stack) |
166f8a29 |
19 | */ |
20 | |
79072805 |
21 | #include "EXTERN.h" |
864dbfa3 |
22 | #define PERL_IN_DEB_C |
79072805 |
23 | #include "perl.h" |
24 | |
c5be433b |
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 | |
8990e307 |
39 | void |
864dbfa3 |
40 | Perl_deb(pTHX_ const char *pat, ...) |
79072805 |
41 | { |
17c3b450 |
42 | #ifdef DEBUGGING |
79072805 |
43 | va_list args; |
c5be433b |
44 | va_start(args, pat); |
45 | vdeb(pat, &args); |
46 | va_end(args); |
65e66c80 |
47 | #else |
48 | PERL_UNUSED_ARG(pat); |
c5be433b |
49 | #endif /* DEBUGGING */ |
50 | } |
51 | |
52 | void |
53 | Perl_vdeb(pTHX_ const char *pat, va_list *args) |
54 | { |
55 | #ifdef DEBUGGING |
97aff369 |
56 | dVAR; |
248c2a4d |
57 | char* file = OutCopFILE(PL_curcop); |
79072805 |
58 | |
cc49e20b |
59 | PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", (file ? file : "<free>"), |
60 | (long)CopLINE(PL_curcop)); |
c5be433b |
61 | (void) PerlIO_vprintf(Perl_debug_log, pat, *args); |
65e66c80 |
62 | #else |
63 | PERL_UNUSED_ARG(pat); |
64 | PERL_UNUSED_ARG(args); |
17c3b450 |
65 | #endif /* DEBUGGING */ |
79072805 |
66 | } |
79072805 |
67 | |
79072805 |
68 | I32 |
864dbfa3 |
69 | Perl_debstackptrs(pTHX) |
79072805 |
70 | { |
17c3b450 |
71 | #ifdef DEBUGGING |
97aff369 |
72 | dVAR; |
b900a521 |
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))); |
17c3b450 |
83 | #endif /* DEBUGGING */ |
79072805 |
84 | return 0; |
85 | } |
86 | |
a0d0e21e |
87 | |
d6721266 |
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 | */ |
1045810a |
96 | |
d6721266 |
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 |
97aff369 |
102 | dVAR; |
d6721266 |
103 | register I32 i = stack_max - 30; |
b64e5050 |
104 | const I32 *markscan = PL_markstack + mark_min; |
d6721266 |
105 | if (i < stack_min) |
106 | i = stack_min; |
a0d0e21e |
107 | |
d6721266 |
108 | while (++markscan <= PL_markstack + mark_max) |
a0d0e21e |
109 | if (*markscan >= i) |
110 | break; |
79072805 |
111 | |
d6721266 |
112 | if (i > stack_min) |
113 | PerlIO_printf(Perl_debug_log, "... "); |
114 | |
115 | if (stack_base[0] != &PL_sv_undef || stack_max < 0) |
760ac839 |
116 | PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n"); |
a0d0e21e |
117 | do { |
118 | ++i; |
d6721266 |
119 | if (markscan <= PL_markstack + mark_max && *markscan < i) { |
a0d0e21e |
120 | do { |
121 | ++markscan; |
760ac839 |
122 | PerlIO_putc(Perl_debug_log, '*'); |
a0d0e21e |
123 | } |
d6721266 |
124 | while (markscan <= PL_markstack + mark_max && *markscan < i); |
760ac839 |
125 | PerlIO_printf(Perl_debug_log, " "); |
79072805 |
126 | } |
d6721266 |
127 | if (i > stack_max) |
a0d0e21e |
128 | break; |
d6721266 |
129 | PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i])); |
79072805 |
130 | } |
a0d0e21e |
131 | while (1); |
760ac839 |
132 | PerlIO_printf(Perl_debug_log, "\n"); |
65e66c80 |
133 | #else |
134 | PERL_UNUSED_ARG(stack_base); |
135 | PERL_UNUSED_ARG(stack_min); |
136 | PERL_UNUSED_ARG(stack_max); |
137 | PERL_UNUSED_ARG(mark_min); |
138 | PERL_UNUSED_ARG(mark_max); |
d6721266 |
139 | #endif /* DEBUGGING */ |
140 | } |
141 | |
142 | |
143 | /* dump the current stack */ |
144 | |
145 | I32 |
146 | Perl_debstack(pTHX) |
147 | { |
148 | #ifndef SKIP_DEBUGGING |
97aff369 |
149 | dVAR; |
d6721266 |
150 | if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) |
151 | return 0; |
152 | |
153 | PerlIO_printf(Perl_debug_log, " => "); |
154 | deb_stack_n(PL_stack_base, |
155 | 0, |
156 | PL_stack_sp - PL_stack_base, |
157 | PL_curstackinfo->si_markoff, |
158 | PL_markstack_ptr - PL_markstack); |
159 | |
160 | |
1045810a |
161 | #endif /* SKIP_DEBUGGING */ |
79072805 |
162 | return 0; |
163 | } |
d6721266 |
164 | |
165 | |
166 | #ifdef DEBUGGING |
0bd48802 |
167 | static const char * const si_names[] = { |
d6721266 |
168 | "UNKNOWN", |
169 | "UNDEF", |
170 | "MAIN", |
171 | "MAGIC", |
172 | "SORT", |
173 | "SIGNAL", |
174 | "OVERLOAD", |
175 | "DESTROY", |
176 | "WARNHOOK", |
177 | "DIEHOOK", |
178 | "REQUIRE" |
179 | }; |
180 | #endif |
181 | |
182 | /* display all stacks */ |
183 | |
184 | |
185 | void |
186 | Perl_deb_stack_all(pTHX) |
187 | { |
188 | #ifdef DEBUGGING |
97aff369 |
189 | dVAR; |
0bd48802 |
190 | I32 si_ix; |
7452cf6a |
191 | const PERL_SI *si; |
d6721266 |
192 | |
193 | /* rewind to start of chain */ |
194 | si = PL_curstackinfo; |
195 | while (si->si_prev) |
196 | si = si->si_prev; |
197 | |
198 | si_ix=0; |
199 | for (;;) |
200 | { |
e1ec3a88 |
201 | const int si_name_ix = si->si_type+1; /* -1 is a valid index */ |
7452cf6a |
202 | const char * const si_name = (si_name_ix>= sizeof(si_names)) ? "????" : si_names[si_name_ix]; |
0bd48802 |
203 | I32 ix; |
d6721266 |
204 | PerlIO_printf(Perl_debug_log, "STACK %"IVdf": %s\n", |
e922992d |
205 | (IV)si_ix, si_name); |
d6721266 |
206 | |
207 | for (ix=0; ix<=si->si_cxix; ix++) { |
208 | |
7452cf6a |
209 | const PERL_CONTEXT * const cx = &(si->si_cxstack[ix]); |
d6721266 |
210 | PerlIO_printf(Perl_debug_log, |
211 | " CX %"IVdf": %-6s => ", |
f1fe7cd8 |
212 | (IV)ix, PL_block_type[CxTYPE(cx)] |
d6721266 |
213 | ); |
214 | /* substitution contexts don't save stack pointers etc) */ |
215 | if (CxTYPE(cx) == CXt_SUBST) |
216 | PerlIO_printf(Perl_debug_log, "\n"); |
217 | else { |
218 | |
219 | /* Find the the current context's stack range by searching |
220 | * forward for any higher contexts using this stack; failing |
221 | * that, it will be equal to the size of the stack for old |
222 | * stacks, or PL_stack_sp for the current stack |
223 | */ |
224 | |
225 | I32 i, stack_min, stack_max, mark_min, mark_max; |
7452cf6a |
226 | const PERL_CONTEXT *cx_n; |
227 | const PERL_SI *si_n; |
d6721266 |
228 | |
229 | cx_n = Null(PERL_CONTEXT*); |
230 | |
231 | /* there's a separate stack per SI, so only search |
232 | * this one */ |
233 | |
234 | for (i=ix+1; i<=si->si_cxix; i++) { |
235 | if (CxTYPE(cx) == CXt_SUBST) |
236 | continue; |
237 | cx_n = &(si->si_cxstack[i]); |
238 | break; |
239 | } |
240 | |
241 | stack_min = cx->blk_oldsp; |
242 | |
243 | if (cx_n) { |
244 | stack_max = cx_n->blk_oldsp; |
245 | } |
246 | else if (si == PL_curstackinfo) { |
247 | stack_max = PL_stack_sp - AvARRAY(si->si_stack); |
248 | } |
249 | else { |
250 | stack_max = AvFILLp(si->si_stack); |
251 | } |
252 | |
253 | /* for the other stack types, there's only one stack |
254 | * shared between all SIs */ |
255 | |
256 | si_n = si; |
257 | i = ix; |
258 | cx_n = Null(PERL_CONTEXT*); |
259 | for (;;) { |
260 | i++; |
261 | if (i > si_n->si_cxix) { |
262 | if (si_n == PL_curstackinfo) |
263 | break; |
264 | else { |
265 | si_n = si_n->si_next; |
266 | i = 0; |
267 | } |
268 | } |
269 | if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST) |
270 | continue; |
271 | cx_n = &(si_n->si_cxstack[i]); |
272 | break; |
273 | } |
274 | |
275 | mark_min = cx->blk_oldmarksp; |
d6721266 |
276 | if (cx_n) { |
277 | mark_max = cx_n->blk_oldmarksp; |
d6721266 |
278 | } |
279 | else { |
280 | mark_max = PL_markstack_ptr - PL_markstack; |
d6721266 |
281 | } |
282 | |
283 | deb_stack_n(AvARRAY(si->si_stack), |
284 | stack_min, stack_max, mark_min, mark_max); |
285 | |
f39bc417 |
286 | if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB |
287 | || CxTYPE(cx) == CXt_FORMAT) |
288 | { |
7452cf6a |
289 | const OP * const retop = (CxTYPE(cx) == CXt_EVAL) |
f39bc417 |
290 | ? cx->blk_eval.retop : cx->blk_sub.retop; |
291 | |
d6721266 |
292 | PerlIO_printf(Perl_debug_log, " retop=%s\n", |
f39bc417 |
293 | retop ? OP_NAME(retop) : "(null)" |
d6721266 |
294 | ); |
295 | } |
d6721266 |
296 | } |
297 | } /* next context */ |
298 | |
299 | |
300 | if (si == PL_curstackinfo) |
301 | break; |
302 | si = si->si_next; |
303 | si_ix++; |
304 | if (!si) |
305 | break; /* shouldn't happen, but just in case.. */ |
306 | } /* next stackinfo */ |
307 | |
308 | PerlIO_printf(Perl_debug_log, "\n"); |
309 | #endif /* DEBUGGING */ |
310 | } |
311 | |
66610fdd |
312 | /* |
313 | * Local variables: |
314 | * c-indentation-style: bsd |
315 | * c-basic-offset: 4 |
316 | * indent-tabs-mode: t |
317 | * End: |
318 | * |
37442d52 |
319 | * ex: set ts=8 sts=4 sw=4 noet: |
320 | */ |