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