ext/Devel/Peek/Peek.xs

   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(pTHX)
  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) || defined(DEBUGGING_MSTATS) \
 120         || (defined(MYMALLOC) && !defined(PLAIN_MALLOC))
 121 #   define mstat(str) dump_mstats(str)
 122 #else
 123 #   define mstat(str) \
 124         PerlIO_printf(PerlIO_stderr(), "%s: perl not compiled with DEBUGGING_MSTATS\n",str);
 125 #endif
 126
 127 MODULE = Devel::Peek            PACKAGE = Devel::Peek
 128
 129 void
 130 mstat(str="Devel::Peek::mstat: ")
 131 char *str
 132
 133 void
 134 Dump(sv,lim=4)
 135 SV *    sv
 136 I32     lim
 137 PPCODE:
 138 {
 139     SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE);
 140     STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
 141     SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE);
 142     I32 save_dumpindent = PL_dumpindent;
 143     PL_dumpindent = 2;
 144     do_sv_dump(0, PerlIO_stderr(), sv, 0, 4, dumpop && SvTRUE(dumpop), pv_lim);
 145     PL_dumpindent = save_dumpindent;
 146 }
 147
 148 void
 149 DumpArray(lim,...)
 150 I32     lim
 151 PPCODE:
 152 {
 153     long i;
 154     SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE);
 155     STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
 156     SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE);
 157     I32 save_dumpindent = PL_dumpindent;
 158     PL_dumpindent = 2;
 159
 160     for (i=1; i<items; i++) {
 161         PerlIO_printf(PerlIO_stderr(), "Elt No. %ld  0x%lx\n", i - 1, ST(i));
 162         do_sv_dump(0, PerlIO_stderr(), ST(i), 0, lim, dumpop && SvTRUE(dumpop), pv_lim);
 163     }
 164     PL_dumpindent = save_dumpindent;
 165 }
 166
 167 void
 168 DumpProg()
 169 PPCODE:
 170 {
 171     warn("dumpindent is %d", PL_dumpindent);
 172     if (PL_main_root)
 173         op_dump(PL_main_root);
 174 }
 175
 176 I32
 177 SvREFCNT(sv)
 178 SV *    sv
 179
 180 # PPCODE needed since otherwise sv_2mortal is inserted that will kill the value.
 181
 182 SV *
 183 SvREFCNT_inc(sv)
 184 SV *    sv
 185 PPCODE:
 186 {
 187     RETVAL = SvREFCNT_inc(sv);
 188     PUSHs(RETVAL);
 189 }
 190
 191 # PPCODE needed since by default it is void
 192
 193 SV *
 194 SvREFCNT_dec(sv)
 195 SV *    sv
 196 PPCODE:
 197 {
 198     SvREFCNT_dec(sv);
 199     PUSHs(sv);
 200 }
 201
 202 SV *
 203 DeadCode()
 204 CODE:
 205     RETVAL = DeadCode(aTHX);
 206 OUTPUT:
 207     RETVAL