diff options
| -rw-r--r-- | dump.c | 2 | ||||
| -rw-r--r-- | embed.fnc | 7 | ||||
| -rw-r--r-- | inline.h | 14 | ||||
| -rw-r--r-- | makedef.pl | 9 | ||||
| -rw-r--r-- | mydtrace.h | 89 | ||||
| -rw-r--r-- | perl.h | 2 | ||||
| -rw-r--r-- | pp_ctl.c | 4 | ||||
| -rw-r--r-- | proto.h | 12 | ||||
| -rw-r--r-- | run.c | 4 | ||||
| -rw-r--r-- | util.c | 78 |
10 files changed, 138 insertions, 83 deletions
@@ -2235,7 +2235,7 @@ Perl_runops_debug(pTHX) LEAVE; } - OP_ENTRY_PROBE(OP_NAME(PL_op)); + PERL_DTRACE_PROBE_OP(PL_op); } while ((PL_op = PL_op->op_ppaddr(aTHX))); DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n")); PERL_ASYNC_CHECK(); @@ -2940,4 +2940,11 @@ AiM |void |cx_pushgiven |NN PERL_CONTEXT *cx|NULLOK SV *orig_defsv AiM |void |cx_popgiven |NN PERL_CONTEXT *cx #endif +#ifdef USE_DTRACE +XEop |void |dtrace_probe_call |NN CV *cv|bool is_call +XEop |void |dtrace_probe_load |NN const char *name|bool is_loading +XEop |void |dtrace_probe_op |NN const OP *op +XEop |void |dtrace_probe_phase|enum perl_phase phase +#endif + : ex: set ts=8 sts=4 sw=4 noet: @@ -480,12 +480,7 @@ S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs) PERL_ARGS_ASSERT_CX_PUSHSUB; - ENTRY_PROBE(CvNAMED(cv) - ? HEK_KEY(CvNAME_HEK(cv)) - : GvENAME(CvGV(cv)), - CopFILE((const COP *)CvSTART(cv)), - CopLINE((const COP *)CvSTART(cv)), - CopSTASHPV((const COP *)CvSTART(cv))); + PERL_DTRACE_PROBE_ENTRY(cv); cx->blk_sub.cv = cv; cx->blk_sub.olddepth = CvDEPTH(cv); cx->blk_sub.prevcomppad = PL_comppad; @@ -545,12 +540,7 @@ S_cx_popsub(pTHX_ PERL_CONTEXT *cx) PERL_ARGS_ASSERT_CX_POPSUB; assert(CxTYPE(cx) == CXt_SUB); - RETURN_PROBE(CvNAMED(cx->blk_sub.cv) - ? HEK_KEY(CvNAME_HEK(cx->blk_sub.cv)) - : GvENAME(CvGV(cx->blk_sub.cv)), - CopFILE((COP*)CvSTART((const CV*)cx->blk_sub.cv)), - CopLINE((COP*)CvSTART((const CV*)cx->blk_sub.cv)), - CopSTASHPV((COP*)CvSTART((const CV*)cx->blk_sub.cv))); + PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv); if (CxHASARGS(cx)) cx_popsub_args(cx); diff --git a/makedef.pl b/makedef.pl index fd3bf62ffe..78ee0b17f5 100644 --- a/makedef.pl +++ b/makedef.pl @@ -427,6 +427,15 @@ unless ($define{'PERL_OP_PARENT'}) { ); } +unless ($define{'USE_DTRACE'}) { + ++$skip{$_} foreach qw( + Perl_dtrace_probe_call + Perl_dtrace_probe_load + Perl_dtrace_probe_op + Perl_dtrace_probe_phase + ); +} + if ($define{'NO_MATHOMS'}) { # win32 builds happen in the win32/ subdirectory, but vms builds happen # at the top level, so we need to look in two candidate locations for diff --git a/mydtrace.h b/mydtrace.h index 6e797676fa..6c66a08509 100644 --- a/mydtrace.h +++ b/mydtrace.h @@ -13,80 +13,39 @@ # include "perldtrace.h" -# if defined(STAP_PROBE_ADDR) && !defined(DEBUGGING) +# define PERL_DTRACE_PROBE_ENTRY(cv) \ + if (PERL_SUB_ENTRY_ENABLED()) \ + Perl_dtrace_probe_call(aTHX_ cv, TRUE); -/* SystemTap 1.2 uses a construct that chokes on passing a char array - * as a char *, in this case hek_key in struct hek. Workaround it - * with a temporary. - */ - -# define ENTRY_PROBE(func, file, line, stash) \ - if (PERL_SUB_ENTRY_ENABLED()) { \ - const char *tmp_func = func; \ - PERL_SUB_ENTRY(tmp_func, file, line, stash); \ - } - -# define RETURN_PROBE(func, file, line, stash) \ - if (PERL_SUB_RETURN_ENABLED()) { \ - const char *tmp_func = func; \ - PERL_SUB_RETURN(tmp_func, file, line, stash); \ - } - -# define LOADING_FILE_PROBE(name) \ - if (PERL_LOADING_FILE_ENABLED()) { \ - const char *tmp_name = name; \ - PERL_LOADING_FILE(tmp_name); \ - } - -# define LOADED_FILE_PROBE(name) \ - if (PERL_LOADED_FILE_ENABLED()) { \ - const char *tmp_name = name; \ - PERL_LOADED_FILE(tmp_name); \ - } - -# else - -# define ENTRY_PROBE(func, file, line, stash) \ - if (PERL_SUB_ENTRY_ENABLED()) { \ - PERL_SUB_ENTRY(func, file, line, stash); \ - } - -# define RETURN_PROBE(func, file, line, stash) \ - if (PERL_SUB_RETURN_ENABLED()) { \ - PERL_SUB_RETURN(func, file, line, stash); \ - } - -# define LOADING_FILE_PROBE(name) \ - if (PERL_LOADING_FILE_ENABLED()) { \ - PERL_LOADING_FILE(name); \ - } +# define PERL_DTRACE_PROBE_RETURN(cv) \ + if (PERL_SUB_ENTRY_ENABLED()) \ + Perl_dtrace_probe_call(aTHX_ cv, FALSE); -# define LOADED_FILE_PROBE(name) \ - if (PERL_LOADED_FILE_ENABLED()) { \ - PERL_LOADED_FILE(name); \ - } +# define PERL_DTRACE_PROBE_FILE_LOADING(name) \ + if (PERL_SUB_ENTRY_ENABLED()) \ + Perl_dtrace_probe_load(aTHX_ name, TRUE); -# endif +# define PERL_DTRACE_PROBE_FILE_LOADED(name) \ + if (PERL_SUB_ENTRY_ENABLED()) \ + Perl_dtrace_probe_load(aTHX_ name, FALSE); -# define OP_ENTRY_PROBE(name) \ - if (PERL_OP_ENTRY_ENABLED()) { \ - PERL_OP_ENTRY(name); \ - } +# define PERL_DTRACE_PROBE_OP(op) \ + if (PERL_OP_ENTRY_ENABLED()) \ + Perl_dtrace_probe_op(aTHX_ op); -# define PHASE_CHANGE_PROBE(new_phase, old_phase) \ - if (PERL_PHASE_CHANGE_ENABLED()) { \ - PERL_PHASE_CHANGE(new_phase, old_phase); \ - } +# define PERL_DTRACE_PROBE_PHASE(phase) \ + if (PERL_OP_ENTRY_ENABLED()) \ + Perl_dtrace_probe_phase(aTHX_ phase); #else /* NOPs */ -# define ENTRY_PROBE(func, file, line, stash) -# define RETURN_PROBE(func, file, line, stash) -# define PHASE_CHANGE_PROBE(new_phase, old_phase) -# define OP_ENTRY_PROBE(name) -# define LOADING_FILE_PROBE(name) -# define LOADED_FILE_PROBE(name) +# define PERL_DTRACE_PROBE_ENTRY(cv) +# define PERL_DTRACE_PROBE_RETURN(cv) +# define PERL_DTRACE_PROBE_FILE_LOADING(cv) +# define PERL_DTRACE_PROBE_FILE_LOADED(cv) +# define PERL_DTRACE_PROBE_OP(op) +# define PERL_DTRACE_PROBE_PHASE(phase) #endif @@ -5241,7 +5241,7 @@ EXTCONST char PL_bincompat_options[]; #ifndef PERL_SET_PHASE # define PERL_SET_PHASE(new_phase) \ - PHASE_CHANGE_PROBE(PL_phase_names[new_phase], PL_phase_names[PL_phase]); \ + PERL_DTRACE_PROBE_PHASE(new_phase); \ PL_phase = new_phase; #endif @@ -3720,7 +3720,7 @@ PP(pp_require) } } - LOADING_FILE_PROBE(unixname); + PERL_DTRACE_PROBE_FILE_LOADING(unixname); /* prepare to compile file */ @@ -4056,7 +4056,7 @@ PP(pp_require) else op = PL_op->op_next; - LOADED_FILE_PROBE(unixname); + PERL_DTRACE_PROBE_FILE_LOADED(unixname); return op; } @@ -5494,6 +5494,18 @@ PERL_CALLCONV bool Perl_dump_c_backtrace(pTHX_ PerlIO* fp, int max_depth, int sk PERL_CALLCONV Perl_c_backtrace* Perl_get_c_backtrace(pTHX_ int max_depth, int skip); PERL_CALLCONV SV* Perl_get_c_backtrace_dump(pTHX_ int max_depth, int skip); #endif +#if defined(USE_DTRACE) +PERL_CALLCONV void Perl_dtrace_probe_call(pTHX_ CV *cv, bool is_call); +#define PERL_ARGS_ASSERT_DTRACE_PROBE_CALL \ + assert(cv) +PERL_CALLCONV void Perl_dtrace_probe_load(pTHX_ const char *name, bool is_loading); +#define PERL_ARGS_ASSERT_DTRACE_PROBE_LOAD \ + assert(name) +PERL_CALLCONV void Perl_dtrace_probe_op(pTHX_ const OP *op); +#define PERL_ARGS_ASSERT_DTRACE_PROBE_OP \ + assert(op) +PERL_CALLCONV void Perl_dtrace_probe_phase(pTHX_ enum perl_phase phase); +#endif #if defined(USE_ITHREADS) PERL_CALLCONV PADOFFSET Perl_alloccopstash(pTHX_ HV *hv); #define PERL_ARGS_ASSERT_ALLOCCOPSTASH \ @@ -37,9 +37,9 @@ int Perl_runops_standard(pTHX) { OP *op = PL_op; - OP_ENTRY_PROBE(OP_NAME(op)); + PERL_DTRACE_PROBE_OP(op); while ((PL_op = op = op->op_ppaddr(aTHX))) { - OP_ENTRY_PROBE(OP_NAME(op)); + PERL_DTRACE_PROBE_OP(op); } PERL_ASYNC_CHECK(); @@ -6652,6 +6652,84 @@ int perl_tsa_mutex_destroy(perl_mutex* mutex) #endif + +#ifdef USE_DTRACE + +/* log a sub call or return */ + +void +Perl_dtrace_probe_call(pTHX_ CV *cv, bool is_call) +{ + const char *func; + const char *file; + const char *stash; + const COP *start; + line_t line; + + PERL_ARGS_ASSERT_DTRACE_PROBE_CALL; + + if (CvNAMED(cv)) { + HEK *hek = CvNAME_HEK(cv); + func = HEK_KEY(hek); + } + else { + GV *gv = CvGV(cv); + func = GvENAME(gv); + } + start = (const COP *)CvSTART(cv); + file = CopFILE(start); + line = CopLINE(start); + stash = CopSTASHPV(start); + + if (is_call) { + PERL_SUB_ENTRY(func, file, line, stash); + } + else { + PERL_SUB_RETURN(func, file, line, stash); + } +} + + +/* log a require file loading/loaded */ + +void +Perl_dtrace_probe_load(pTHX_ const char *name, bool is_loading) +{ + PERL_ARGS_ASSERT_DTRACE_PROBE_LOAD; + + if (is_loading) { + PERL_LOADING_FILE(name); + } + else { + PERL_LOADED_FILE(name); + } +} + + +/* log an op execution */ + +void +Perl_dtrace_probe_op(pTHX_ const OP *op) +{ + PERL_ARGS_ASSERT_DTRACE_PROBE_OP; + + PERL_OP_ENTRY(OP_NAME(op)); +} + + +/* log a compile/run phase change */ + +void +Perl_dtrace_probe_phase(pTHX_ enum perl_phase phase) +{ + const char *ph_old = PL_phase_names[PL_phase]; + const char *ph_new = PL_phase_names[phase]; + + PERL_PHASE_CHANGE(ph_new, ph_old); +} + +#endif + /* * ex: set ts=8 sts=4 sw=4 et: */ |