1 #define PERL_NO_GET_CONTEXT 2 #include "EXTERN.h" 3 #include "perl.h" 4 #include "XSUB.h" 5 6 static bool 7 _runops_debug(int flag) 8 { 9 dTHX; 10 const bool d = PL_runops == MEMBER_TO_FPTR(Perl_runops_debug); 11 12 if (flag >= 0) 13 PL_runops 14 = MEMBER_TO_FPTR(flag ? Perl_runops_debug : Perl_runops_standard); 15 return d; 16 } 17 18 static SV * 19 DeadCode(pTHX) 20 { 21 #ifdef PURIFY 22 return Nullsv; 23 #else 24 SV* sva; 25 SV* sv; 26 SV* ret = newRV_noinc((SV*)newAV()); 27 register SV* svend; 28 int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0; 29 30 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { 31 svend = &sva[SvREFCNT(sva)]; 32 for (sv = sva + 1; sv < svend; ++sv) { 33 if (SvTYPE(sv) == SVt_PVCV) { 34 CV *cv = (CV*)sv; 35 AV* padlist = CvPADLIST(cv), *argav; 36 SV** svp; 37 SV** pad; 38 int i = 0, j, levelm, totm = 0, levelref, totref = 0; 39 int levels, tots = 0, levela, tota = 0, levelas, totas = 0; 40 int dumpit = 0; 41 42 if (CvISXSUB(sv)) { 43 continue; /* XSUB */ 44 } 45 if (!CvGV(sv)) { 46 continue; /* file-level scope. */ 47 } 48 if (!CvROOT(cv)) { 49 /* PerlIO_printf(Perl_debug_log, " no root?!\n"); */ 50 continue; /* autoloading stub. */ 51 } 52 do_gvgv_dump(0, Perl_debug_log, "GVGV::GV", CvGV(sv)); 53 if (CvDEPTH(cv)) { 54 PerlIO_printf(Perl_debug_log, " busy\n"); 55 continue; 56 } 57 svp = AvARRAY(padlist); 58 while (++i <= AvFILL(padlist)) { /* Depth. */ 59 SV **args; 60 61 pad = AvARRAY((AV*)svp[i]); 62 argav = (AV*)pad[0]; 63 if (!argav || (SV*)argav == &PL_sv_undef) { 64 PerlIO_printf(Perl_debug_log, " closure-template\n"); 65 continue; 66 } 67 args = AvARRAY(argav); 68 levelm = levels = levelref = levelas = 0; 69 levela = sizeof(SV*) * (AvMAX(argav) + 1); 70 if (AvREAL(argav)) { 71 for (j = 0; j < AvFILL(argav); j++) { 72 if (SvROK(args[j])) { 73 PerlIO_printf(Perl_debug_log, " ref in args!\n"); 74 levelref++; 75 } 76 /* else if (SvPOK(args[j]) && SvPVX(args[j])) { */ 77 else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) { 78 levelas += SvLEN(args[j])/SvREFCNT(args[j]); 79 } 80 } 81 } 82 for (j = 1; j < AvFILL((AV*)svp[1]); j++) { /* Vars. */ 83 if (SvROK(pad[j])) { 84 levelref++; 85 do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0); 86 dumpit = 1; 87 } 88 /* else if (SvPOK(pad[j]) && SvPVX(pad[j])) { */ 89 else if (SvTYPE(pad[j]) >= SVt_PVAV) { 90 if (!SvPADMY(pad[j])) { 91 levelref++; 92 do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0); 93 dumpit = 1; 94 } 95 } 96 else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) { 97 levels++; 98 levelm += SvLEN(pad[j])/SvREFCNT(pad[j]); 99 /* Dump(pad[j],4); */ 100 } 101 } 102 PerlIO_printf(Perl_debug_log, " level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n", 103 i, levelref, levelm, levels, levela, levelas); 104 totm += levelm; 105 tota += levela; 106 totas += levelas; 107 tots += levels; 108 totref += levelref; 109 if (dumpit) 110 do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0); 111 } 112 if (AvFILL(padlist) > 1) { 113 PerlIO_printf(Perl_debug_log, " total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n", 114 totref, totm, tots, tota, totas); 115 } 116 tref += totref; 117 tm += totm; 118 ts += tots; 119 ta += tota; 120 tas += totas; 121 } 122 } 123 } 124 PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas); 125 126 return ret; 127 #endif /* !PURIFY */ 128 } 129 130 #if defined(MYMALLOC) 131 # define mstat(str) dump_mstats(str) 132 #else 133 # define mstat(str) \ 134 PerlIO_printf(Perl_debug_log, "%s: perl not compiled with MYMALLOC\n",str); 135 #endif 136 137 #if defined(MYMALLOC) 138 139 /* Very coarse overestimate, 2-per-power-of-2, one more to determine NBUCKETS. */ 140 # define _NBUCKETS (2*8*IVSIZE+1) 141 142 struct mstats_buffer 143 { 144 perl_mstats_t buffer; 145 UV buf[_NBUCKETS*4]; 146 }; 147 148 static void 149 _fill_mstats(struct mstats_buffer *b, int level) 150 { 151 dTHX; 152 b->buffer.nfree = b->buf; 153 b->buffer.ntotal = b->buf + _NBUCKETS; 154 b->buffer.bucket_mem_size = b->buf + 2*_NBUCKETS; 155 b->buffer.bucket_available_size = b->buf + 3*_NBUCKETS; 156 Zero(b->buf, (level ? 4*_NBUCKETS: 2*_NBUCKETS), unsigned long); 157 get_mstats(&(b->buffer), _NBUCKETS, level); 158 } 159 160 static void 161 fill_mstats(SV *sv, int level) 162 { 163 dTHX; 164 165 if (SvREADONLY(sv)) 166 croak("Cannot modify a readonly value"); 167 SvGROW(sv, sizeof(struct mstats_buffer)+1); 168 _fill_mstats((struct mstats_buffer*)SvPVX(sv),level); 169 SvCUR_set(sv, sizeof(struct mstats_buffer)); 170 *SvEND(sv) = '\0'; 171 SvPOK_only(sv); 172 } 173 174 static void 175 _mstats_to_hv(HV *hv, const struct mstats_buffer *b, int level) 176 { 177 dTHX; 178 SV **svp; 179 int type; 180 181 svp = hv_fetch(hv, "topbucket", 9, 1); 182 sv_setiv(*svp, b->buffer.topbucket); 183 184 svp = hv_fetch(hv, "topbucket_ev", 12, 1); 185 sv_setiv(*svp, b->buffer.topbucket_ev); 186 187 svp = hv_fetch(hv, "topbucket_odd", 13, 1); 188 sv_setiv(*svp, b->buffer.topbucket_odd); 189 190 svp = hv_fetch(hv, "totfree", 7, 1); 191 sv_setiv(*svp, b->buffer.totfree); 192 193 svp = hv_fetch(hv, "total", 5, 1); 194 sv_setiv(*svp, b->buffer.total); 195 196 svp = hv_fetch(hv, "total_chain", 11, 1); 197 sv_setiv(*svp, b->buffer.total_chain); 198 199 svp = hv_fetch(hv, "total_sbrk", 10, 1); 200 sv_setiv(*svp, b->buffer.total_sbrk); 201 202 svp = hv_fetch(hv, "sbrks", 5, 1); 203 sv_setiv(*svp, b->buffer.sbrks); 204 205 svp = hv_fetch(hv, "sbrk_good", 9, 1); 206 sv_setiv(*svp, b->buffer.sbrk_good); 207 208 svp = hv_fetch(hv, "sbrk_slack", 10, 1); 209 sv_setiv(*svp, b->buffer.sbrk_slack); 210 211 svp = hv_fetch(hv, "start_slack", 11, 1); 212 sv_setiv(*svp, b->buffer.start_slack); 213 214 svp = hv_fetch(hv, "sbrked_remains", 14, 1); 215 sv_setiv(*svp, b->buffer.sbrked_remains); 216 217 svp = hv_fetch(hv, "minbucket", 9, 1); 218 sv_setiv(*svp, b->buffer.minbucket); 219 220 svp = hv_fetch(hv, "nbuckets", 8, 1); 221 sv_setiv(*svp, b->buffer.nbuckets); 222 223 if (_NBUCKETS < b->buffer.nbuckets) 224 warn("FIXME: internal mstats buffer too short"); 225 226 for (type = 0; type < (level ? 4 : 2); type++) { 227 UV *p = 0, *p1 = 0, i; 228 AV *av; 229 static const char *types[4] = { 230 "free", "used", "mem_size", "available_size" 231 }; 232 233 svp = hv_fetch(hv, types[type], strlen(types[type]), 1); 234 235 if (SvOK(*svp) && !(SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV)) 236 croak("Unexpected value for the key '%s' in the mstats hash", types[type]); 237 if (!SvOK(*svp)) { 238 av = newAV(); 239 (void)SvUPGRADE(*svp, SVt_RV); 240 SvRV_set(*svp, (SV*)av); 241 SvROK_on(*svp); 242 } else 243 av = (AV*)SvRV(*svp); 244 245 av_extend(av, b->buffer.nbuckets - 1); 246 /* XXXX What is the official way to reduce the size of the array? */ 247 switch (type) { 248 case 0: 249 p = b->buffer.nfree; 250 break; 251 case 1: 252 p = b->buffer.ntotal; 253 p1 = b->buffer.nfree; 254 break; 255 case 2: 256 p = b->buffer.bucket_mem_size; 257 break; 258 case 3: 259 p = b->buffer.bucket_available_size; 260 break; 261 } 262 for (i = 0; i < b->buffer.nbuckets; i++) { 263 svp = av_fetch(av, i, 1); 264 if (type == 1) 265 sv_setiv(*svp, p[i]-p1[i]); 266 else 267 sv_setuv(*svp, p[i]); 268 } 269 } 270 } 271 272 static void 273 mstats_fillhash(SV *sv, int level) 274 { 275 struct mstats_buffer buf; 276 277 if (!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV)) 278 croak("Not a hash reference"); 279 _fill_mstats(&buf, level); 280 _mstats_to_hv((HV *)SvRV(sv), &buf, level); 281 } 282 283 static void 284 mstats2hash(SV *sv, SV *rv, int level) 285 { 286 if (!(SvROK(rv) && SvTYPE(SvRV(rv)) == SVt_PVHV)) 287 croak("Not a hash reference"); 288 if (!SvPOK(sv)) 289 croak("Undefined value when expecting mstats buffer"); 290 if (SvCUR(sv) != sizeof(struct mstats_buffer)) 291 croak("Wrong size for a value with a mstats buffer"); 292 _mstats_to_hv((HV *)SvRV(rv), (struct mstats_buffer*)SvPVX(sv), level); 293 } 294 #else /* defined(MYMALLOC) */ 295 static void 296 fill_mstats(SV *sv, int level) 297 { 298 croak("Cannot report mstats without Perl malloc"); 299 } 300 301 static void 302 mstats_fillhash(SV *sv, int level) 303 { 304 croak("Cannot report mstats without Perl malloc"); 305 } 306 307 static void 308 mstats2hash(SV *sv, SV *rv, int level) 309 { 310 croak("Cannot report mstats without Perl malloc"); 311 } 312 #endif /* defined(MYMALLOC) */ 313 314 #define _CvGV(cv) \ 315 (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV) \ 316 ? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef) 317 318 MODULE = Devel::Peek PACKAGE = Devel::Peek 319 320 void 321 mstat(str="Devel::Peek::mstat: ") 322 const char *str 323 324 void 325 fill_mstats(SV *sv, int level = 0) 326 327 void 328 mstats_fillhash(SV *sv, int level = 0) 329 PROTOTYPE: \%;$ 330 331 void 332 mstats2hash(SV *sv, SV *rv, int level = 0) 333 PROTOTYPE: $\%;$ 334 335 void 336 Dump(sv,lim=4) 337 SV * sv 338 I32 lim 339 PPCODE: 340 { 341 SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", 0); 342 const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; 343 SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", 0); 344 const U16 save_dumpindent = PL_dumpindent; 345 PL_dumpindent = 2; 346 do_sv_dump(0, Perl_debug_log, sv, 0, lim, 347 (bool)(dumpop && SvTRUE(dumpop)), pv_lim); 348 PL_dumpindent = save_dumpindent; 349 } 350 351 void 352 DumpArray(lim,...) 353 I32 lim 354 PPCODE: 355 { 356 long i; 357 SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", 0); 358 const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; 359 SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", 0); 360 const U16 save_dumpindent = PL_dumpindent; 361 PL_dumpindent = 2; 362 363 for (i=1; i<items; i++) { 364 PerlIO_printf(Perl_debug_log, "Elt No. %ld 0x%"UVxf"\n", i - 1, PTR2UV(ST(i))); 365 do_sv_dump(0, Perl_debug_log, ST(i), 0, lim, 366 (bool)(dumpop && SvTRUE(dumpop)), pv_lim); 367 } 368 PL_dumpindent = save_dumpindent; 369 } 370 371 void 372 DumpProg() 373 PPCODE: 374 { 375 warn("dumpindent is %d", (int)PL_dumpindent); 376 if (PL_main_root) 377 op_dump(PL_main_root); 378 } 379 380 I32 381 SvREFCNT(sv) 382 SV * sv 383 384 # PPCODE needed since otherwise sv_2mortal is inserted that will kill the value. 385 386 SV * 387 SvREFCNT_inc(sv) 388 SV * sv 389 PPCODE: 390 { 391 RETVAL = SvREFCNT_inc(sv); 392 PUSHs(RETVAL); 393 } 394 395 # PPCODE needed since by default it is void 396 397 void 398 SvREFCNT_dec(sv) 399 SV * sv 400 PPCODE: 401 { 402 SvREFCNT_dec(sv); 403 PUSHs(sv); 404 } 405 406 SV * 407 DeadCode() 408 CODE: 409 RETVAL = DeadCode(aTHX); 410 OUTPUT: 411 RETVAL 412 413 MODULE = Devel::Peek PACKAGE = Devel::Peek PREFIX = _ 414 415 SV * 416 _CvGV(cv) 417 SV *cv 418 419 bool 420 _runops_debug(int flag = -1) 421