source: trunk/third/perl/deb.c @ 20075

Revision 20075, 6.5 KB checked in by zacheiss, 21 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r20074, which included commits to RCS files with non-trunk default branches.
Line 
1/*    deb.c
2 *
3 *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1998, 1999,
4 *    2000, 2001, 2002, 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#include "EXTERN.h"
17#define PERL_IN_DEB_C
18#include "perl.h"
19
20#if defined(PERL_IMPLICIT_CONTEXT)
21void
22Perl_deb_nocontext(const char *pat, ...)
23{
24#ifdef DEBUGGING
25    dTHX;
26    va_list args;
27    va_start(args, pat);
28    vdeb(pat, &args);
29    va_end(args);
30#endif /* DEBUGGING */
31}
32#endif
33
34void
35Perl_deb(pTHX_ const char *pat, ...)
36{
37#ifdef DEBUGGING
38    va_list args;
39    va_start(args, pat);
40    vdeb(pat, &args);
41    va_end(args);
42#endif /* DEBUGGING */
43}
44
45void
46Perl_vdeb(pTHX_ const char *pat, va_list *args)
47{
48#ifdef DEBUGGING
49    char* file = OutCopFILE(PL_curcop);
50
51#ifdef USE_5005THREADS
52    PerlIO_printf(Perl_debug_log, "0x%"UVxf" (%s:%ld)\t",
53                  PTR2UV(thr),
54                  (file ? file : "<free>"),
55                  (long)CopLINE(PL_curcop));
56#else
57    PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", (file ? file : "<free>"),
58                  (long)CopLINE(PL_curcop));
59#endif /* USE_5005THREADS */
60    (void) PerlIO_vprintf(Perl_debug_log, pat, *args);
61#endif /* DEBUGGING */
62}
63
64I32
65Perl_debstackptrs(pTHX)
66{
67#ifdef DEBUGGING
68    PerlIO_printf(Perl_debug_log,
69                  "%8"UVxf" %8"UVxf" %8"IVdf" %8"IVdf" %8"IVdf"\n",
70                  PTR2UV(PL_curstack), PTR2UV(PL_stack_base),
71                  (IV)*PL_markstack_ptr, (IV)(PL_stack_sp-PL_stack_base),
72                  (IV)(PL_stack_max-PL_stack_base));
73    PerlIO_printf(Perl_debug_log,
74                  "%8"UVxf" %8"UVxf" %8"UVuf" %8"UVuf" %8"UVuf"\n",
75                  PTR2UV(PL_mainstack), PTR2UV(AvARRAY(PL_curstack)),
76                  PTR2UV(PL_mainstack), PTR2UV(AvFILLp(PL_curstack)),
77                  PTR2UV(AvMAX(PL_curstack)));
78#endif /* DEBUGGING */
79    return 0;
80}
81
82
83/* dump the contents of a particular stack
84 * Display stack_base[stack_min+1 .. stack_max],
85 * and display the marks whose offsets are contained in addresses
86 * PL_markstack[mark_min+1 .. mark_max] and whose values are in the range
87 * of the stack values being displayed
88 *
89 * Only displays top 30 max
90 */
91
92STATIC void
93S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max,
94        I32 mark_min, I32 mark_max)
95{
96#ifdef DEBUGGING
97    register I32 i = stack_max - 30;
98    I32 *markscan = PL_markstack + mark_min;
99    if (i < stack_min)
100        i = stack_min;
101   
102    while (++markscan <= PL_markstack + mark_max)
103        if (*markscan >= i)
104            break;
105
106    if (i > stack_min)
107        PerlIO_printf(Perl_debug_log, "... ");
108
109    if (stack_base[0] != &PL_sv_undef || stack_max < 0)
110        PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
111    do {
112        ++i;
113        if (markscan <= PL_markstack + mark_max && *markscan < i) {
114            do {
115                ++markscan;
116                PerlIO_putc(Perl_debug_log, '*');
117            }
118            while (markscan <= PL_markstack + mark_max && *markscan < i);
119            PerlIO_printf(Perl_debug_log, "  ");
120        }
121        if (i > stack_max)
122            break;
123        PerlIO_printf(Perl_debug_log, "%-4s  ", SvPEEK(stack_base[i]));
124    }
125    while (1);
126    PerlIO_printf(Perl_debug_log, "\n");
127#endif /* DEBUGGING */
128}
129
130
131/* dump the current stack */
132
133I32
134Perl_debstack(pTHX)
135{
136#ifndef SKIP_DEBUGGING
137    if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
138        return 0;
139
140    PerlIO_printf(Perl_debug_log, "    =>  ");
141    deb_stack_n(PL_stack_base,
142                0,
143                PL_stack_sp - PL_stack_base,
144                PL_curstackinfo->si_markoff,
145                PL_markstack_ptr - PL_markstack);
146
147
148#endif /* SKIP_DEBUGGING */
149    return 0;
150}
151
152
153#ifdef DEBUGGING
154static char * si_names[] = {
155    "UNKNOWN",
156    "UNDEF",
157    "MAIN",
158    "MAGIC",
159    "SORT",
160    "SIGNAL",
161    "OVERLOAD",
162    "DESTROY",
163    "WARNHOOK",
164    "DIEHOOK",
165    "REQUIRE"
166};
167#endif
168
169/* display all stacks */
170
171
172void
173Perl_deb_stack_all(pTHX)
174{
175#ifdef DEBUGGING
176    I32          ix, si_ix;
177    PERL_SI      *si;
178    PERL_CONTEXT *cx;
179
180    /* rewind to start of chain */
181    si = PL_curstackinfo;
182    while (si->si_prev)
183        si = si->si_prev;
184
185    si_ix=0;
186    for (;;)
187    {
188        char *si_name;
189        int si_name_ix = si->si_type+1; /* -1 is a valid index */
190        if (si_name_ix>= sizeof(si_names))
191            si_name = "????";
192        else
193            si_name = 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            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 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
Note: See TracBrowser for help on using the repository browser.