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