This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
e7f5746803545b74fe1d527aae029a8a1c12ca0f
[perl5.git] / ext / Devel / Peek / Peek.xs
1 #define PERL_NO_GET_CONTEXT
2 #include "EXTERN.h"
3 #include "perl.h"
4 #include "XSUB.h"
5
6 SV *
7 DeadCode(pTHX)
8 {
9 #ifdef PURIFY
10     return Nullsv;
11 #else
12     SV* sva;
13     SV* sv, *dbg;
14     SV* ret = newRV_noinc((SV*)newAV());
15     register SV* svend;
16     int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0;
17
18     for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
19         svend = &sva[SvREFCNT(sva)];
20         for (sv = sva + 1; sv < svend; ++sv) {
21             if (SvTYPE(sv) == SVt_PVCV) {
22                 CV *cv = (CV*)sv;
23                 AV* padlist = CvPADLIST(cv), *argav;
24                 SV** svp;
25                 SV** pad;
26                 int i = 0, j, levelm, totm = 0, levelref, totref = 0;
27                 int levels, tots = 0, levela, tota = 0, levelas, totas = 0;
28                 int dumpit = 0;
29
30                 if (CvXSUB(sv)) {
31                     continue;           /* XSUB */
32                 }
33                 if (!CvGV(sv)) {
34                     continue;           /* file-level scope. */
35                 }
36                 if (!CvROOT(cv)) {
37                     /* PerlIO_printf(Perl_debug_log, "  no root?!\n"); */
38                     continue;           /* autoloading stub. */
39                 }
40                 do_gvgv_dump(0, Perl_debug_log, "GVGV::GV", CvGV(sv));
41                 if (CvDEPTH(cv)) {
42                     PerlIO_printf(Perl_debug_log, "  busy\n");
43                     continue;
44                 }
45                 svp = AvARRAY(padlist);
46                 while (++i <= AvFILL(padlist)) { /* Depth. */
47                     SV **args;
48                     
49                     pad = AvARRAY((AV*)svp[i]);
50                     argav = (AV*)pad[0];
51                     if (!argav || (SV*)argav == &PL_sv_undef) {
52                         PerlIO_printf(Perl_debug_log, "    closure-template\n");
53                         continue;
54                     }
55                     args = AvARRAY(argav);
56                     levelm = levels = levelref = levelas = 0;
57                     levela = sizeof(SV*) * (AvMAX(argav) + 1);
58                     if (AvREAL(argav)) {
59                         for (j = 0; j < AvFILL(argav); j++) {
60                             if (SvROK(args[j])) {
61                                 PerlIO_printf(Perl_debug_log, "     ref in args!\n");
62                                 levelref++;
63                             }
64                             /* else if (SvPOK(args[j]) && SvPVX(args[j])) { */
65                             else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) {
66                                 levelas += SvLEN(args[j])/SvREFCNT(args[j]);
67                             }
68                         }
69                     }
70                     for (j = 1; j < AvFILL((AV*)svp[1]); j++) { /* Vars. */
71                         if (SvROK(pad[j])) {
72                             levelref++;
73                             do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
74                             dumpit = 1;
75                         }
76                         /* else if (SvPOK(pad[j]) && SvPVX(pad[j])) { */
77                         else if (SvTYPE(pad[j]) >= SVt_PVAV) {
78                             if (!SvPADMY(pad[j])) {
79                                 levelref++;
80                                 do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
81                                 dumpit = 1;
82                             }
83                         }
84                         else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) {
85                             int db_len = SvLEN(pad[j]);
86                             SV *db_sv = pad[j];
87                             levels++;
88                             levelm += SvLEN(pad[j])/SvREFCNT(pad[j]);
89                                 /* Dump(pad[j],4); */
90                         }
91                     }
92                     PerlIO_printf(Perl_debug_log, "    level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n", 
93                             i, levelref, levelm, levels, levela, levelas);
94                     totm += levelm;
95                     tota += levela;
96                     totas += levelas;
97                     tots += levels;
98                     totref += levelref;
99                     if (dumpit)
100                         do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0);
101                 }
102                 if (AvFILL(padlist) > 1) {
103                     PerlIO_printf(Perl_debug_log, "  total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n", 
104                             totref, totm, tots, tota, totas);
105                 }
106                 tref += totref;
107                 tm += totm;
108                 ts += tots;
109                 ta += tota;
110                 tas += totas;
111             }
112         }
113     }
114     PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas);
115
116     return ret;
117 #endif /* !PURIFY */
118 }
119
120 #if defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS) \
121         || (defined(MYMALLOC) && !defined(PLAIN_MALLOC))
122 #   define mstat(str) dump_mstats(str)
123 #else
124 #   define mstat(str) \
125         PerlIO_printf(Perl_debug_log, "%s: perl not compiled with DEBUGGING_MSTATS\n",str);
126 #endif
127
128 #define _CvGV(cv)                                       \
129         (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV)      \
130          ? (SV*)CvGV((CV*)SvRV(cv)) : &PL_sv_undef)
131
132 MODULE = Devel::Peek            PACKAGE = Devel::Peek
133
134 void
135 mstat(str="Devel::Peek::mstat: ")
136 char *str
137
138 void
139 Dump(sv,lim=4)
140 SV *    sv
141 I32     lim
142 PPCODE:
143 {
144     SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE);
145     STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
146     SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE);
147     I32 save_dumpindent = PL_dumpindent;
148     PL_dumpindent = 2;
149     do_sv_dump(0, Perl_debug_log, sv, 0, lim, dumpop && SvTRUE(dumpop), pv_lim);
150     PL_dumpindent = save_dumpindent;
151 }
152
153 void
154 DumpArray(lim,...)
155 I32     lim
156 PPCODE:
157 {
158     long i;
159     SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE);
160     STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
161     SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE);
162     I32 save_dumpindent = PL_dumpindent;
163     PL_dumpindent = 2;
164
165     for (i=1; i<items; i++) {
166         PerlIO_printf(Perl_debug_log, "Elt No. %ld  0x%"UVxf"\n", i - 1, PTR2UV(ST(i)));
167         do_sv_dump(0, Perl_debug_log, ST(i), 0, lim, dumpop && SvTRUE(dumpop), pv_lim);
168     }
169     PL_dumpindent = save_dumpindent;
170 }
171
172 void
173 DumpProg()
174 PPCODE:
175 {
176     warn("dumpindent is %d", PL_dumpindent);
177     if (PL_main_root)
178         op_dump(PL_main_root);
179 }
180
181 I32
182 SvREFCNT(sv)
183 SV *    sv
184
185 # PPCODE needed since otherwise sv_2mortal is inserted that will kill the value.
186
187 SV *
188 SvREFCNT_inc(sv)
189 SV *    sv
190 PPCODE:
191 {
192     RETVAL = SvREFCNT_inc(sv);
193     PUSHs(RETVAL);
194 }
195
196 # PPCODE needed since by default it is void
197
198 SV *
199 SvREFCNT_dec(sv)
200 SV *    sv
201 PPCODE:
202 {
203     SvREFCNT_dec(sv);
204     PUSHs(sv);
205 }
206
207 SV *
208 DeadCode()
209 CODE:
210     RETVAL = DeadCode(aTHX);
211 OUTPUT:
212     RETVAL
213
214 MODULE = Devel::Peek            PACKAGE = Devel::Peek   PREFIX = _
215
216 SV *
217 _CvGV(cv)
218     SV *cv