1#define PERL_NO_GET_CONTEXT 2#include "EXTERN.h" 3#include "perl.h" 4#include "XSUB.h" 5 6static bool 7_runops_debug(int flag) 8{ 9 dTHX; 10 const bool d = PL_runops == Perl_runops_debug; 11 12 if (flag >= 0) 13 PL_runops = flag ? Perl_runops_debug : Perl_runops_standard; 14 return d; 15} 16 17static SV * 18DeadCode(pTHX) 19{ 20#ifdef PURIFY 21 return Nullsv; 22#else 23 SV* sva; 24 SV* sv; 25 SV* ret = newRV_noinc((SV*)newAV()); 26 SV* svend; 27 int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0; 28 29 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { 30 svend = &sva[SvREFCNT(sva)]; 31 for (sv = sva + 1; sv < svend; ++sv) { 32 if (SvTYPE(sv) == SVt_PVCV) { 33 CV *cv = (CV*)sv; 34 PADLIST* padlist; 35 AV *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 padlist = CvPADLIST(cv); 58 svp = (SV**) PadlistARRAY(padlist); 59 while (++i <= PadlistMAX(padlist)) { /* Depth. */ 60 SV **args; 61 62 if (!svp[i]) continue; 63 pad = AvARRAY((AV*)svp[i]); 64 argav = (AV*)pad[0]; 65 if (!argav || (SV*)argav == &PL_sv_undef) { 66 PerlIO_printf(Perl_debug_log, " closure-template\n"); 67 continue; 68 } 69 args = AvARRAY(argav); 70 levelm = levels = levelref = levelas = 0; 71 levela = sizeof(SV*) * (AvMAX(argav) + 1); 72 if (AvREAL(argav)) { 73 for (j = 0; j < AvFILL(argav); j++) { 74 if (SvROK(args[j])) { 75 PerlIO_printf(Perl_debug_log, " ref in args!\n"); 76 levelref++; 77 } 78 /* else if (SvPOK(args[j]) && SvPVX(args[j])) { */ 79 else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) { 80 levelas += SvLEN(args[j])/SvREFCNT(args[j]); 81 } 82 } 83 } 84 for (j = 1; j < AvFILL((AV*)svp[1]); j++) { /* Vars. */ 85 if (!pad[j]) continue; 86 if (SvROK(pad[j])) { 87 levelref++; 88 do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0); 89 dumpit = 1; 90 } 91 /* else if (SvPOK(pad[j]) && SvPVX(pad[j])) { */ 92 else if (SvTYPE(pad[j]) >= SVt_PVAV) { 93 if (!SvPADMY(pad[j])) { 94 levelref++; 95 do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0); 96 dumpit = 1; 97 } 98 } 99 else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) { 100 levels++; 101 levelm += SvLEN(pad[j])/SvREFCNT(pad[j]); 102 /* Dump(pad[j],4); */ 103 } 104 } 105 PerlIO_printf(Perl_debug_log, " level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n", 106 i, levelref, levelm, levels, levela, levelas); 107 totm += levelm; 108 tota += levela; 109 totas += levelas; 110 tots += levels; 111 totref += levelref; 112 if (dumpit) 113 do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0); 114 } 115 if (PadlistMAX(padlist) > 1) { 116 PerlIO_printf(Perl_debug_log, " total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n", 117 totref, totm, tots, tota, totas); 118 } 119 tref += totref; 120 tm += totm; 121 ts += tots; 122 ta += tota; 123 tas += totas; 124 } 125 } 126 } 127 PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas); 128 129 return ret; 130#endif /* !PURIFY */ 131} 132 133#if defined(MYMALLOC) 134# define mstat(str) dump_mstats(str) 135#else 136# define mstat(str) \ 137 PerlIO_printf(Perl_debug_log, "%s: perl not compiled with MYMALLOC\n",str); 138#endif 139 140#if defined(MYMALLOC) 141 142/* Very coarse overestimate, 2-per-power-of-2, one more to determine NBUCKETS. */ 143# define _NBUCKETS (2*8*IVSIZE+1) 144 145struct mstats_buffer 146{ 147 perl_mstats_t buffer; 148 UV buf[_NBUCKETS*4]; 149}; 150 151static void 152_fill_mstats(struct mstats_buffer *b, int level) 153{ 154 dTHX; 155 b->buffer.nfree = b->buf; 156 b->buffer.ntotal = b->buf + _NBUCKETS; 157 b->buffer.bucket_mem_size = b->buf + 2*_NBUCKETS; 158 b->buffer.bucket_available_size = b->buf + 3*_NBUCKETS; 159 Zero(b->buf, (level ? 4*_NBUCKETS: 2*_NBUCKETS), unsigned long); 160 get_mstats(&(b->buffer), _NBUCKETS, level); 161} 162 163static void 164fill_mstats(SV *sv, int level) 165{ 166 dTHX; 167 168 if (SvREADONLY(sv)) 169 croak("Cannot modify a readonly value"); 170 sv_grow(sv, sizeof(struct mstats_buffer)+1); 171 _fill_mstats((struct mstats_buffer*)SvPVX(sv),level); 172 SvCUR_set(sv, sizeof(struct mstats_buffer)); 173 *SvEND(sv) = '\0'; 174 SvPOK_only(sv); 175} 176 177static void 178_mstats_to_hv(HV *hv, const struct mstats_buffer *b, int level) 179{ 180 dTHX; 181 SV **svp; 182 int type; 183 184 svp = hv_fetchs(hv, "topbucket", 1); 185 sv_setiv(*svp, b->buffer.topbucket); 186 187 svp = hv_fetchs(hv, "topbucket_ev", 1); 188 sv_setiv(*svp, b->buffer.topbucket_ev); 189 190 svp = hv_fetchs(hv, "topbucket_odd", 1); 191 sv_setiv(*svp, b->buffer.topbucket_odd); 192 193 svp = hv_fetchs(hv, "totfree", 1); 194 sv_setiv(*svp, b->buffer.totfree); 195 196 svp = hv_fetchs(hv, "total", 1); 197 sv_setiv(*svp, b->buffer.total); 198 199 svp = hv_fetchs(hv, "total_chain", 1); 200 sv_setiv(*svp, b->buffer.total_chain); 201 202 svp = hv_fetchs(hv, "total_sbrk", 1); 203 sv_setiv(*svp, b->buffer.total_sbrk); 204 205 svp = hv_fetchs(hv, "sbrks", 1); 206 sv_setiv(*svp, b->buffer.sbrks); 207 208 svp = hv_fetchs(hv, "sbrk_good", 1); 209 sv_setiv(*svp, b->buffer.sbrk_good); 210 211 svp = hv_fetchs(hv, "sbrk_slack", 1); 212 sv_setiv(*svp, b->buffer.sbrk_slack); 213 214 svp = hv_fetchs(hv, "start_slack", 1); 215 sv_setiv(*svp, b->buffer.start_slack); 216 217 svp = hv_fetchs(hv, "sbrked_remains", 1); 218 sv_setiv(*svp, b->buffer.sbrked_remains); 219 220 svp = hv_fetchs(hv, "minbucket", 1); 221 sv_setiv(*svp, b->buffer.minbucket); 222 223 svp = hv_fetchs(hv, "nbuckets", 1); 224 sv_setiv(*svp, b->buffer.nbuckets); 225 226 if (_NBUCKETS < b->buffer.nbuckets) 227 warn("FIXME: internal mstats buffer too short"); 228 229 for (type = 0; type < (level ? 4 : 2); type++) { 230 UV *p = 0, *p1 = 0, i; 231 AV *av; 232 static const char *types[4] = { 233 "free", "used", "mem_size", "available_size" 234 }; 235 236 svp = hv_fetch(hv, types[type], strlen(types[type]), 1); 237 238 if (SvOK(*svp) && !(SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV)) 239 croak("Unexpected value for the key '%s' in the mstats hash", types[type]); 240 if (!SvOK(*svp)) { 241 av = newAV(); 242 sv_setrv_noinc(*svp, (SV*)av); 243 } else 244 av = (AV*)SvRV(*svp); 245 246 av_extend(av, b->buffer.nbuckets - 1); 247 /* XXXX What is the official way to reduce the size of the array? */ 248 switch (type) { 249 case 0: 250 p = b->buffer.nfree; 251 break; 252 case 1: 253 p = b->buffer.ntotal; 254 p1 = b->buffer.nfree; 255 break; 256 case 2: 257 p = b->buffer.bucket_mem_size; 258 break; 259 case 3: 260 p = b->buffer.bucket_available_size; 261 break; 262 } 263 for (i = 0; i < b->buffer.nbuckets; i++) { 264 svp = av_fetch(av, i, 1); 265 if (type == 1) 266 sv_setiv(*svp, p[i]-p1[i]); 267 else 268 sv_setuv(*svp, p[i]); 269 } 270 } 271} 272 273static void 274mstats_fillhash(SV *sv, int level) 275{ 276 struct mstats_buffer buf; 277 278 if (!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV)) 279 croak("Not a hash reference"); 280 _fill_mstats(&buf, level); 281 _mstats_to_hv((HV *)SvRV(sv), &buf, level); 282} 283 284static void 285mstats2hash(SV *sv, SV *rv, int level) 286{ 287 if (!(SvROK(rv) && SvTYPE(SvRV(rv)) == SVt_PVHV)) 288 croak("Not a hash reference"); 289 if (!SvPOK(sv)) 290 croak("Undefined value when expecting mstats buffer"); 291 if (SvCUR(sv) != sizeof(struct mstats_buffer)) 292 croak("Wrong size for a value with a mstats buffer"); 293 _mstats_to_hv((HV *)SvRV(rv), (struct mstats_buffer*)SvPVX(sv), level); 294} 295#else /* defined(MYMALLOC) */ 296static void 297fill_mstats(SV *sv, int level) 298{ 299 PERL_UNUSED_ARG(sv); 300 PERL_UNUSED_ARG(level); 301 croak("Cannot report mstats without Perl malloc"); 302} 303 304static void 305mstats_fillhash(SV *sv, int level) 306{ 307 PERL_UNUSED_ARG(sv); 308 PERL_UNUSED_ARG(level); 309 croak("Cannot report mstats without Perl malloc"); 310} 311 312static void 313mstats2hash(SV *sv, SV *rv, int level) 314{ 315 PERL_UNUSED_ARG(sv); 316 PERL_UNUSED_ARG(rv); 317 PERL_UNUSED_ARG(level); 318 croak("Cannot report mstats without Perl malloc"); 319} 320#endif /* defined(MYMALLOC) */ 321 322#define _CvGV(cv) \ 323 (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV) \ 324 ? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef) 325 326static void 327S_do_dump(pTHX_ SV *const sv, I32 lim) 328{ 329 SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", 0); 330 const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; 331 SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", 0); 332 const U16 save_dumpindent = PL_dumpindent; 333 PL_dumpindent = 2; 334 do_sv_dump(0, Perl_debug_log, sv, 0, lim, 335 (bool)(dumpop && SvTRUE(dumpop)), pv_lim); 336 PL_dumpindent = save_dumpindent; 337} 338 339static OP * 340S_pp_dump(pTHX) 341{ 342 dSP; 343 const I32 lim = PL_op->op_private == 2 ? (I32)POPi : 4; 344 dPOPss; 345 S_do_dump(aTHX_ sv, lim); 346 RETPUSHUNDEF; 347} 348 349static OP * 350S_ck_dump(pTHX_ OP *entersubop, GV *namegv, SV *cv) 351{ 352 OP *parent, *pm, *first, *second; 353 BINOP *newop; 354 355 PERL_UNUSED_ARG(cv); 356 357 ck_entersub_args_proto(entersubop, namegv, 358 newSVpvn_flags("$;$", 3, SVs_TEMP)); 359 360 parent = entersubop; 361 pm = cUNOPx(entersubop)->op_first; 362 if (!OpHAS_SIBLING(pm)) { 363 parent = pm; 364 pm = cUNOPx(pm)->op_first; 365 } 366 first = OpSIBLING(pm); 367 second = OpSIBLING(first); 368 if (!second) { 369 /* It doesn���t really matter what we return here, as this only 370 occurs after yyerror. */ 371 return entersubop; 372 } 373 /* we either have Dump($x): [pushmark]->[first]->[ex-cvop] 374 * or Dump($x,1); [pushmark]->[first]->[second]->[ex-cvop] 375 */ 376 if (!OpHAS_SIBLING(second)) 377 second = NULL; 378 379 if (first->op_type == OP_RV2AV || 380 first->op_type == OP_PADAV || 381 first->op_type == OP_RV2HV || 382 first->op_type == OP_PADHV 383 ) 384 first->op_flags |= OPf_REF; 385 else 386 first->op_flags &= ~OPf_MOD; 387 388 /* splice out first (and optionally second) ops, then discard the rest 389 * of the op tree */ 390 391 op_sibling_splice(parent, pm, second ? 2 : 1, NULL); 392 op_free(entersubop); 393 394 /* then attach first (and second) to a new binop */ 395 396 NewOp(1234, newop, 1, BINOP); 397 newop->op_type = OP_CUSTOM; 398 newop->op_ppaddr = S_pp_dump; 399 newop->op_private= second ? 2 : 1; 400 newop->op_flags = OPf_KIDS|OPf_WANT_SCALAR; 401 op_sibling_splice((OP*)newop, NULL, 0, first); 402 403 return (OP *)newop; 404} 405 406static const XOP my_xop = { 407 XOPf_xop_name|XOPf_xop_desc|XOPf_xop_class, /* xop_flags */ 408 "Devel_Peek_Dump", /* xop_name */ 409 "Dump", /* xop_desc */ 410 OA_BINOP, /* xop_class */ 411 NULL /* xop_peep */ 412}; 413 414MODULE = Devel::Peek PACKAGE = Devel::Peek 415 416void 417mstat(str="Devel::Peek::mstat: ") 418const char *str 419 420void 421fill_mstats(SV *sv, int level = 0) 422 423void 424mstats_fillhash(SV *sv, int level = 0) 425 PROTOTYPE: \%;$ 426 427void 428mstats2hash(SV *sv, SV *rv, int level = 0) 429 PROTOTYPE: $\%;$ 430 431void 432Dump(sv,lim=4) 433SV * sv 434I32 lim 435PPCODE: 436{ 437 S_do_dump(aTHX_ sv, lim); 438} 439 440BOOT: 441{ 442 CV * const cv = get_cvn_flags("Devel::Peek::Dump", 17, 0); 443 assert(cv); 444 cv_set_call_checker_flags(cv, S_ck_dump, (SV *)cv, 0); 445 Perl_custom_op_register(aTHX_ S_pp_dump, &my_xop); 446} 447 448void 449DumpArray(lim,...) 450I32 lim 451PPCODE: 452{ 453 long i; 454 SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", 0); 455 const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; 456 SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", 0); 457 const U16 save_dumpindent = PL_dumpindent; 458 PL_dumpindent = 2; 459 460 for (i=1; i<items; i++) { 461 PerlIO_printf(Perl_debug_log, "Elt No. %ld 0x%" UVxf "\n", i - 1, PTR2UV(ST(i))); 462 do_sv_dump(0, Perl_debug_log, ST(i), 0, lim, 463 (bool)(dumpop && SvTRUE(dumpop)), pv_lim); 464 } 465 PL_dumpindent = save_dumpindent; 466} 467 468void 469DumpProg() 470PPCODE: 471{ 472 warn("dumpindent is %d", (int)PL_dumpindent); 473 if (PL_main_root) 474 op_dump(PL_main_root); 475} 476 477U32 478SvREFCNT(sv) 479SV * sv 480PROTOTYPE: \[$@%&*] 481CODE: 482 SvGETMAGIC(sv); 483 if (!SvROK(sv)) 484 croak_xs_usage(cv, "SCALAR"); 485 RETVAL = SvREFCNT(SvRV(sv)) - 1; /* -1 because our ref doesn't count */ 486OUTPUT: 487 RETVAL 488 489SV * 490DeadCode() 491CODE: 492 RETVAL = DeadCode(aTHX); 493OUTPUT: 494 RETVAL 495 496MODULE = Devel::Peek PACKAGE = Devel::Peek PREFIX = _ 497 498SV * 499_CvGV(cv) 500 SV *cv 501 502bool 503_runops_debug(int flag = -1) 504