I've ported my additional DTrace probes to blead perl, and have attached
a patch.
This patch adds
**new-sv and del-sv to track Perl allocations,
**main-enter and main-exit to show what part of Perl's execution phase
we're in
**load-module-entry and load-module-return to instrument use, require, do.
As you can see from the code in op.c, I have not worked out howto get
all the desired information from perl yet - the staggering amount of
TLA's is blowing this 1week old Perl hacker's mind a bit.
Any tips and pointers would be appreciated - I'd like to get this merged :)
I've started to document the probes at
http://wikis.sun.com/display/DTrace/perl+Provider
Cheers
Sven
--
Professional Wiki Innovation and Support
Sven Dowideit - http://DistributedINFORMATION.com
A WikiRing Partner http://wikiring.com
Index: perl.c
===================================================================
--- perl.c (revision 125)
+++ 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;
}
@@ -2394,6 +2417,7 @@
PL_op = PL_main_start;
CALLRUNOPS(aTHX);
}
+
my_exit(0);
/* NOTREACHED */
}
Index: Makefile.SH
===================================================================
--- Makefile.SH (revision 125)
+++ 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 125)
+++ perldtrace.d (working copy)
@@ -1,9 +1,45 @@
/*
- * Written by Alan Burlinson -- taken from his blog post
+ * Begun by Alan Burlinson -- taken from his blog post
* at <http://blogs.sun.com/alanbur/date/20050909>.
+ * added to by Sven Dowideit --
+ * <http://distributedinformation.com/>
*/
provider perl {
+ /* 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 125)
+++ op.c (working copy)
@@ -3805,6 +3805,19 @@
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_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_UTILIZE;
if (idop->op_type != OP_CONST)
@@ -3904,6 +3917,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 */
@@ -3962,6 +3976,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;
@@ -3998,6 +4013,7 @@
utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
veop, modname, imop);
LEAVE;
+ LOAD_MODULE_RETURN_PROBE(SvPVX(name));
}
OP *
@@ -4007,6 +4023,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) {
@@ -4026,6 +4053,7 @@
else {
doop = newUNOP(OP_DOFILE, 0, scalar(term));
}
+ LOAD_MODULE_RETURN_PROBE(probe_output);
return doop;
}
@@ -7468,6 +7496,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? */
@@ -7529,9 +7572,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 125)
+++ 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;
}
@@ -269,11 +270,12 @@
STMT_START { \
if (PL_sv_root) \
uproot_SV(p); \
- else \
- (p) = S_more_sv(aTHX); \
+ else \
+ (p) = S_more_sv(aTHX); \
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 125)
+++ 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
_______________________________________________
dtrace-discuss mailing list
[email protected]
