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 #ifdef PURIFY
   7 #define DeadCode() NULL
   8 #else
   9 SV *
  10 DeadCode(pTHX)
  11 {
  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 }
 118 #endif /* !PURIFY */
 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