Index: perl.c =================================================================== --- perl.c (revision 127) +++ perl.c (working copy) @@ -270,11 +270,16 @@ perl_alloc(void) { PerlInterpreter *my_perl; + + MAIN_ENTER_PROBE(); /* Newx() needs interpreter, so call malloc() instead */ my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); S_init_tls_and_interp(my_perl); + + MAIN_EXIT_PROBE(); + #ifndef PERL_TRACK_MEMPOOL return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter); #else @@ -300,6 +305,8 @@ PERL_ARGS_ASSERT_PERL_CONSTRUCT; + MAIN_ENTER_PROBE(); + #ifdef MULTIPLICITY init_interp(); PL_perl_destruct_level = 1; @@ -456,6 +463,7 @@ PL_timesbase.tms_cutime = 0; PL_timesbase.tms_cstime = 0; #endif + MAIN_EXIT_PROBE(); ENTER; } @@ -593,6 +601,7 @@ #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP pid_t child; #endif + MAIN_ENTER_PROBE(); PERL_ARGS_ASSERT_PERL_DESTRUCT; #ifndef MULTIPLICITY @@ -632,7 +641,8 @@ if (CALL_FPTR(PL_threadhook)(aTHX)) { /* Threads hook has vetoed further cleanup */ - PL_veto_cleanup = TRUE; + PL_veto_cleanup = TRUE; + MAIN_EXIT_PROBE(); return STATUS_EXIT; } @@ -647,12 +657,14 @@ if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) { perror("Debug leaking scalars socketpair failed"); + MAIN_EXIT_PROBE(); abort(); } child = fork(); if(child == -1) { perror("Debug leaking scalars fork failed"); + MAIN_EXIT_PROBE(); abort(); } if (!child) { @@ -681,6 +693,7 @@ f = sysconf(_SC_OPEN_MAX); if(f < 0) { where = "sysconf failed"; + MAIN_EXIT_PROBE(); goto abort; } while (f--) { @@ -764,6 +777,7 @@ goto abort; } } + MAIN_EXIT_PROBE(); _exit(0); abort: { @@ -781,6 +795,7 @@ So sleep a bit to give the parent a fighting chance of reading the data. */ sleep(2); + MAIN_EXIT_PROBE(); _exit((got == -1) ? errno : 0); } /* End of child. */ @@ -884,6 +899,7 @@ CopSTASH_free(&PL_compiling); /* The exit() function will do everything that needs doing. */ + MAIN_EXIT_PROBE(); return STATUS_EXIT; } @@ -1347,6 +1363,7 @@ Safefree(PL_mess_sv); PL_mess_sv = NULL; } + MAIN_EXIT_PROBE(); return STATUS_EXIT; } @@ -1508,6 +1525,8 @@ I32 oldscope; int ret; dJMPENV; + + MAIN_ENTER_PROBE(); PERL_ARGS_ASSERT_PERL_PARSE; #ifndef MULTIPLICITY @@ -1641,6 +1660,7 @@ S_set_caret_X(aTHX); TAINT_NOT; init_postdump_symbols(argc,argv,env); + MAIN_EXIT_PROBE(); return 0; } @@ -1687,6 +1707,7 @@ break; } JMPENV_POP; + MAIN_EXIT_PROBE(); return ret; } @@ -2293,6 +2314,7 @@ int ret = 0; dJMPENV; + MAIN_ENTER_PROBE(); PERL_ARGS_ASSERT_PERL_RUN; #ifndef MULTIPLICITY PERL_UNUSED_ARG(my_perl); @@ -2338,6 +2360,7 @@ } JMPENV_POP; + MAIN_EXIT_PROBE(); return ret; } Index: Makefile.SH =================================================================== --- Makefile.SH (revision 127) +++ Makefile.SH (working copy) @@ -624,8 +624,8 @@ case "$dtrace_o" in ?*) $spitshell >>Makefile <<'!NO!SUBS!' -$(DTRACE_O): perldtrace.d - $(DTRACE) -G -s perldtrace.d -o $(DTRACE_O) $(ndt_obj) +$(DTRACE_O): perldtrace.d $(DTRACE_H) $(ndt_obj) opmini.o + $(DTRACE) -G -s perldtrace.d -o $(DTRACE_O) $(ndt_obj) opmini.o !NO!SUBS! ;; Index: perldtrace.d =================================================================== --- perldtrace.d (revision 127) +++ perldtrace.d (working copy) @@ -1,9 +1,39 @@ /* - * Written by Alan Burlinson -- taken from his blog post + * Begun by Alan Burlinson -- taken from his blog post * at . + * added to by Sven Dowideit -- + * */ provider perl { - probe sub__entry(char *, char *, int); + /* function, filename, line number */ + probe sub__entry(char *, char *, int); + /* filename, line number */ probe sub__return(char *, char *, int); + + /* new & delete (perl uses reference counting gc, so there is no 'gc sweep') */ + /* function, SV* */ + probe new__sv(void*); + /* function, SV* */ + probe del__sv(void*); + + /* Perl main processing (adds a probe to perl_alloc, perl_construct, perl_parse, perl_run, perl_deconstruct ) */ + probe main__enter(); + probe main__exit(); + + /* use, require, do */ + /* function, char* module_name */ + probe load__module__entry(char *); + /* function, char* module_name */ + probe load__module__return(char *); }; + + + +/* need to read up & set.. +#pragma D attributes Evolving/Evolving/Common provider perl provider +#pragma D attributes Private/Private/Common provider perl module +#pragma D attributes Private/Private/Common provider perl function +#pragma D attributes Evolving/Evolving/Common provider perl name +#pragma D attributes Evolving/Evolving/Common provider perl args +*/ Index: op.c =================================================================== --- op.c (revision 127) +++ op.c (working copy) @@ -3811,6 +3811,22 @@ OP *pegop = newOP(OP_NULL,0); #endif + char probe_output[256]; + if (PERL_LOAD_MODULE_ENTRY_ENABLED() || PERL_LOAD_MODULE_RETURN_ENABLED()) { + SV * sv = ((SVOP*)idop)->op_sv; + if (SvTYPE(sv) == SVt_PV) { + snprintf(probe_output, 255,"%s\0", SvPVX(sv)); + } else if (SvTYPE(sv) == SVt_PVMG) { + /* require 5.6 etc*/ + MAGIC *magic = SvMAGIC(sv); + if (magic->mg_len > 0) { + snprintf(probe_output, 255, "%s\0", magic->mg_ptr); + } + } else { + snprintf(probe_output, 255,"TODO: SV not a ptr/number, its a 0x%x\0", SvTYPE(sv)); + } + LOAD_MODULE_ENTRY_PROBE(probe_output); + } PERL_ARGS_ASSERT_UTILIZE; if (idop->op_type != OP_CONST) @@ -3910,6 +3926,7 @@ PL_parser->expect = XSTATE; PL_cop_seqmax++; /* Purely for B::*'s benefit */ + LOAD_MODULE_RETURN_PROBE(probe_output); #ifdef PERL_MAD if (!PL_madskills) { /* FIXME - don't allocate pegop if !PL_madskills */ @@ -3968,6 +3985,7 @@ OP *veop, *imop; OP * const modname = newSVOP(OP_CONST, 0, name); + LOAD_MODULE_ENTRY_PROBE(SvPVX(name)); PERL_ARGS_ASSERT_VLOAD_MODULE; modname->op_private |= OPpCONST_BARE; @@ -4004,6 +4022,7 @@ utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); LEAVE; + LOAD_MODULE_RETURN_PROBE(SvPVX(name)); } OP * @@ -4013,6 +4032,17 @@ OP *doop; GV *gv = NULL; + char probe_output[256]; + if (PERL_LOAD_MODULE_ENTRY_ENABLED() || PERL_LOAD_MODULE_RETURN_ENABLED()) { + if (term->op_type == OP_CONST) { + SV * const sv = ((SVOP*)term)->op_sv; + snprintf(probe_output, 255,"%s\0", SvPVX(sv)); + } else { + /* TODO: the above crashed when its an OP_PADSV (9) */ + snprintf(probe_output, 255, "TODO: modname not an OP_CONST, its a (%u)", term->op_type); + } + } + LOAD_MODULE_ENTRY_PROBE(probe_output); PERL_ARGS_ASSERT_DOFILE; if (!force_builtin) { @@ -4032,6 +4062,7 @@ else { doop = newUNOP(OP_DOFILE, 0, scalar(term)); } + LOAD_MODULE_RETURN_PROBE(probe_output); return doop; } @@ -7474,6 +7505,21 @@ dVAR; GV* gv = NULL; + + char probe_output[256]; + if (PERL_LOAD_MODULE_ENTRY_ENABLED() || PERL_LOAD_MODULE_RETURN_ENABLED()) { + SVOP * const kid = (SVOP*)cUNOPo->op_first; + SV * sv = ((SVOP*)kid)->op_sv; + if (SvTYPE(sv) == SVt_PV) { + snprintf(probe_output, 255,"%s\0", SvPVX(sv)); + } else if (SvTYPE(sv) == SVt_NV) { /*looks like this has changed dramatically since 5.8*/ + /* require 5.6 etc*/ + snprintf(probe_output, 255,"%f\0", SvNVX(sv)); + } else { + snprintf(probe_output, 255,"TODO: SV not a ptr/number, its a 0x%x\0", SvTYPE(sv)); + } + } + LOAD_MODULE_ENTRY_PROBE(probe_output); PERL_ARGS_ASSERT_CK_REQUIRE; if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ @@ -7535,9 +7581,11 @@ newGVOP(OP_GV, 0, gv)))))); op_getmad(o,newop,'O'); + LOAD_MODULE_RETURN_PROBE(probe_output); return newop; } + LOAD_MODULE_RETURN_PROBE(probe_output); return ck_fun(o); } Index: sv.c =================================================================== --- sv.c (revision 128) +++ sv.c (working copy) @@ -259,6 +259,7 @@ sv->sv_debug_inpad = 0; sv->sv_debug_cloned = 0; sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL; + NEW_SV_PROBE((sv)); return sv; } @@ -274,6 +275,7 @@ SvANY(p) = 0; \ SvREFCNT(p) = 1; \ SvFLAGS(p) = 0; \ + NEW_SV_PROBE((p)); \ } STMT_END #endif @@ -284,6 +286,7 @@ #define del_SV(p) \ STMT_START { \ + DEL_SV_PROBE(p); \ if (DEBUG_D_TEST) \ del_sv(p); \ else \ @@ -321,7 +324,11 @@ #else /* ! DEBUGGING */ -#define del_SV(p) plant_SV(p) +#define del_SV(p) \ + STMT_START { \ + DEL_SV_PROBE(p); \ + plant_SV(p); \ + } STMT_END #endif /* DEBUGGING */ Index: mydtrace.h =================================================================== --- mydtrace.h (revision 127) +++ mydtrace.h (working copy) @@ -23,11 +23,48 @@ PERL_SUB_RETURN(func, file, line); \ } +# define NEW_SV_PROBE(probe_sv_ptr) \ + if (PERL_NEW_SV_ENABLED()) { \ + PERL_NEW_SV((void*)(probe_sv_ptr)); \ + } + +# define DEL_SV_PROBE(probe_sv_ptr) \ + if (PERL_DEL_SV_ENABLED()) { \ + PERL_DEL_SV((void*)(probe_sv_ptr)); \ + } + +# define MAIN_ENTER_PROBE() \ + if (PERL_MAIN_ENTER_ENABLED()) { \ + PERL_MAIN_ENTER(); \ + } + +# define MAIN_EXIT_PROBE() \ + if (PERL_MAIN_EXIT_ENABLED()) { \ + PERL_MAIN_EXIT(); \ + } + +# define LOAD_MODULE_ENTRY_PROBE(probe_module_name_ptr) \ + if (PERL_LOAD_MODULE_ENTRY_ENABLED()) { \ + PERL_LOAD_MODULE_ENTRY((probe_module_name_ptr)); \ + } + +# define LOAD_MODULE_RETURN_PROBE(probe_module_name_ptr) \ + if (PERL_LOAD_MODULE_RETURN_ENABLED()) { \ + PERL_LOAD_MODULE_RETURN((probe_module_name_ptr)); \ + } + + #else /* NOPs */ # define ENTRY_PROBE(func, file, line) # define RETURN_PROBE(func, file, line) +# define NEW_SV_PROBE(probe_sv_ptr) +# define DEL_SV_PROBE(probe_sv_ptr) +# define MAIN_ENTER_PROBE() +# define MAIN_EXIT_PROBE() +# define LOAD_MODULE_ENTRY_PROBE(probe_module_name_ptr) +# define LOAD_MODULE_RETURN_PROBE(probe_module_name_ptr) #endif