This patch is based on Alan Burlison's blog entry at . Please note that you must select the option to build libperl as a dynamic library, otherwise perl will not be DTrace'able. This is a bug and will hopefully be fixed at some point. Currently the dependencies are not quite right -- cop.h depends on perldtrace.h, but the Makefile rules are not right. You'll need to do this, after running Configure: make perldtrace.h I've included some example DTrace scripts that I've been testing with. How to test this patch works, once you've built perl with it: (1) In one terminal session, change into your perl build directory and run miniperl like this: LD_LIBRARY_PATH=`pwd` ./miniperl \ -e 'sub foo { print shift; }; while (<>) { foo($_); }' (2) In another terminal session, change into your perl build directory and run DTrace on one of the example scripts included in this patch. ps -af | grep miniperl dtrace -p -s subs-tree.d Then flip back to the miniperl terminal session, type lines of any old garbage in. You should see something like this in your DTrace terminal session: -> foo (-e:1) <- foo (-e:1) -> foo (-e:1) <- foo (-e:1) -> foo (-e:1) <- foo (-e:1) Richard Dawe --- perl-5.8.8.orig/Configure 2006-01-08 14:51:03.000000000 +0000 +++ perl-5.8.8/Configure 2007-07-16 17:45:57.067544000 +0100 @@ -1159,6 +1159,7 @@ use5005threads='' useithreads='' usereentrant='' usethreads='' +usedtrace='' incpath='' mips_type='' usrinc='' @@ -8768,6 +8769,27 @@ set usefaststdio eval $setvar +case "$usedtrace" in +$define|true|[yY]*|'') ;; +*) dflt='n';; +esac +cat <>Makefile <<'!NO!SUBS!' +dtrace_obj = perldtrace$(OBJ_EXT) + +# XXX: Find dtrace executable, rather than hard-coding its location. + +perldtrace.h: perldtrace.d + /usr/sbin/dtrace -h -s perldtrace.d -o perldtrace.h + +perldtrace$(OBJ_EXT): perldtrace.d $(obj) miniperlmain$(OBJ_EXT) perl$(OBJ_EXT) + /usr/sbin/dtrace -G -s perldtrace.d -o perldtrace$(OBJ_EXT) $(obj) miniperlmain$(OBJ_EXT) perl$(OBJ_EXT) + +!NO!SUBS! + ;; + esac $spitshell >>Makefile <<'!NO!SUBS!' -$(LIBPERL): $& perl$(OBJ_EXT) $(obj) $(LIBPERLEXPORT) +$(LIBPERL): $& perl$(OBJ_EXT) $(obj) $(dtrace_obj) $(LIBPERLEXPORT) !NO!SUBS! case "$useshrplib" in true) $spitshell >>Makefile <<'!NO!SUBS!' - $(LD) -o $@ $(SHRPLDFLAGS) perl$(OBJ_EXT) $(obj) $(libs) + $(LD) -o $@ $(SHRPLDFLAGS) perl$(OBJ_EXT) $(obj) $(dtrace_obj) $(libs) !NO!SUBS! case "$osname" in aix) @@ -565,7 +581,7 @@ $(LIBPERL): $& perl$(OBJ_EXT) $(obj) $(L *) $spitshell >>Makefile <<'!NO!SUBS!' rm -f $(LIBPERL) - $(AR) rcu $(LIBPERL) perl$(OBJ_EXT) $(obj) + $(AR) rcu $(LIBPERL) perl$(OBJ_EXT) $(obj) $(dtrace_obj) @$(ranlib) $(LIBPERL) !NO!SUBS! ;; --- perl-5.8.8.orig/config_h.SH 2005-10-31 18:13:05.000000000 +0000 +++ perl-5.8.8/config_h.SH 2007-07-17 22:53:50.050559000 +0100 @@ -3675,6 +3675,12 @@ sed <$CONFIG_H -e 's!^#und #$d_oldpthreads OLD_PTHREADS_API /**/ #$usereentrant USE_REENTRANT_API /**/ +/* USE_DTRACE + * This symbol, if defined, indicates that Perl should + * be built with support for DTrace. + */ +#$usedtrace USE_DTRACE /**/ + /* PERL_VENDORARCH: * If defined, this symbol contains the name of a private library. * The library is private in the sense that it needn't be in anyone's --- perl-5.8.8.orig/cop.h 2005-09-21 17:09:16.000000000 +0100 +++ perl-5.8.8/cop.h 2007-07-20 13:15:21.084121000 +0100 @@ -13,6 +13,11 @@ * and thus can be used to determine our current state. */ +#ifdef USE_DTRACE +#define _DTRACE_VERSION 1 +#endif +#include "perldtrace.h" + struct cop { BASEOP char * cop_label; /* label for this construct */ @@ -121,6 +126,10 @@ struct block_sub { * decremented by LEAVESUB, the other by LEAVE. */ #define PUSHSUB_BASE(cx) \ + PERL_SUB_ENTRY(GvENAME(CvGV(cv)), \ + CopFILE((COP*)CvSTART(cv)), \ + CopLINE((COP*)CvSTART(cv))); \ + \ cx->blk_sub.cv = cv; \ cx->blk_sub.olddepth = CvDEPTH(cv); \ cx->blk_sub.hasargs = hasargs; \ @@ -168,8 +177,13 @@ struct block_sub { AvFILLp(ary) = -1; \ } STMT_END + #define POPSUB(cx,sv) \ STMT_START { \ + PERL_SUB_RETURN(GvENAME(CvGV((CV*)cx->blk_sub.cv)), \ + CopFILE((COP*)CvSTART((CV*)cx->blk_sub.cv)), \ + CopLINE((COP*)CvSTART((CV*)cx->blk_sub.cv))); \ + \ if (cx->blk_sub.hasargs) { \ POP_SAVEARRAY(); \ /* abandon @_ if it got reified */ \ --- /dev/null 2007-07-20 14:02:16.000000000 +0100 +++ perl-5.8.8/perldtrace.d 2007-07-19 21:26:15.432253000 +0100 @@ -0,0 +1,9 @@ +/* + * Written by Alan Burlinson -- taken from his blog post + * at . + */ + +provider perl { + probe sub__entry(char*, char*, int); + probe sub__return(char*, char*, int); +}; --- /dev/null 2007-07-20 14:02:16.000000000 +0100 +++ perl-5.8.8/page-faults.d 2007-07-18 12:19:03.566565000 +0100 @@ -0,0 +1,37 @@ +/* + * Written by Alan Burlinson -- taken from his blog post + * at . + */ + +#pragma D option quiet + +BEGIN +{ + self->sub = "PERL"; + self->file = "PERL"; +} + +perl$target:::sub-entry +{ + self->sub = copyinstr(arg0); + self->file = copyinstr(arg1); +} + +perl$target:::sub-return +{ + self->sub = "PERL"; + self->file = "PERL"; +} + +vminfo:::maj_fault, +vminfo:::zfod, +vminfo:::as_fault +/self->sub != 0/ +{ + @pf[self->sub, self->file] = count(); +} + +END +{ + printa("%@8d %-20s %s\n", @pf); +} --- /dev/null 2007-07-20 14:02:16.000000000 +0100 +++ perl-5.8.8/subs.d 2007-07-20 13:24:33.314969000 +0100 @@ -0,0 +1,28 @@ +#pragma D option quiet + +perl$target:::sub-entry +{ + mysub = copyinstr(arg0); + myfile = copyinstr(arg1); + + @entries[mysub, myfile] = count(); +} + +perl$target:::sub-return +{ + mysub = copyinstr(arg0); + myfile = copyinstr(arg1); + + @returns[mysub, myfile] = count(); +} + +END +{ + printf("Subs called into:\n"); + printa("%@8u %-20s %s\n", @entries); + printf("\n"); + + printf("Subs returned from:\n"); + printa("%@8u %-20s %s\n", @returns); + printf("\n"); +} --- /dev/null 2007-07-20 14:02:16.000000000 +0100 +++ perl-5.8.8/subs-old.d 2007-07-20 13:24:14.960902000 +0100 @@ -0,0 +1,38 @@ +#pragma D option quiet + +/* XXX: Why do I have to specify all function names? */ +/* XXX: How to make this easier? */ +perl$target::Perl_pp_sort:sub-entry, + perl$target::Perl_pp_dbstate:sub-entry, + perl$target::Perl_pp_entersub:sub-entry +{ + mysub = copyinstr(arg0); + myfile = copyinstr(arg1); + + @entries[mysub, myfile] = count(); +} + +/* XXX: Why do I have to specify all function names? */ +/* XXX: How to make this easier? */ +perl$target::Perl_pp_last:sub-return, + perl$target::Perl_pp_return:sub-return, + perl$target::Perl_dounwind:sub-return, + perl$target::Perl_pp_leavesublv:sub-return, + perl$target::Perl_pp_leavesub:sub-return +{ + mysub = copyinstr(arg0); + myfile = copyinstr(arg1); + + @returns[mysub, myfile] = count(); +} + +END +{ + printf("Subs called into:\n"); + printa("%@8u %-20s %s\n", @entries); + printf("\n"); + + printf("Subs returned from:\n"); + printa("%@8u %-20s %s\n", @returns); + printf("\n"); +} --- /dev/null 2007-07-20 14:02:16.000000000 +0100 +++ perl-5.8.8/subs-tree.d 2007-07-20 13:29:22.611042000 +0100 @@ -0,0 +1,11 @@ +#pragma D option quiet + +perl$target:::sub-entry, perl$target:::sub-return +{ + /* + * Borrowed and modified from the Python DTrace example + * at + */ + printf("%s %s (%s:%d)\n", probename == "sub-entry" ? "->" : "<-", + copyinstr(arg0), copyinstr(arg1), arg2); +}