6 # Devel::DProf - a Perl code profiler
10 # changes/bugs fixed since 2apr95 version:
11 # -now mallocing an extra byte for the \0 :)
12 # changes/bugs fixed since 01mar95 version:
13 # -stringified code ref is used for name of anonymous sub.
14 # -include stash name with stringified code ref.
15 # -use perl.c's DBsingle and DBsub.
16 # -now using croak() and warn().
17 # -print "timer is on" before turning timer on.
18 # -use safefree() instead of free().
19 # -rely on PM to provide full path name to tmon.out.
20 # -print errno if unable to write tmon.out.
21 # changes/bugs fixed since 03feb95 version:
23 # changes/bugs fixed since 31dec94 version:
24 # -added patches from Andy.
28 /*#define DBG_SUB 1 /* */
29 /*#define DBG_TIMER 1 /* */
32 # define DBG_SUB_NOTIFY(A,B) warn( A, B )
34 # define DBG_SUB_NOTIFY(A,B) /* nothing */
38 # define DBG_TIMER_NOTIFY(A) warn( A )
40 # define DBG_TIMER_NOTIFY(A) /* nothing */
43 /* HZ == clock ticks per second */
48 static SV * Sub; /* pointer to $DB::sub */
49 static char *Tmon; /* name of tmon.out */
51 /* Everything is built on times(2). See its manpage for a description
56 struct tms prof_start,
60 clock_t rprof_start, /* elapsed real time, in ticks */
64 clock_t tms_utime; /* cpu time spent in user space */
65 clock_t tms_stime; /* cpu time spent in system */
66 clock_t realtime; /* elapsed real time, in ticks */
71 typedef union prof_any PROFANY;
73 static PROFANY *profstack;
74 static int profstack_max = 128;
75 static int profstack_ix = 0;
89 if( profstack_ix + 5 > profstack_max ){
90 profstack_max = profstack_max * 3 / 2;
91 Renew( profstack, profstack_max, PROFANY );
95 pv = SvPV( Sub, len );
98 /* Attempt to make CODE refs identifiable by
99 * including their package name.
102 if( sv && SvTYPE(sv) == SVt_PVCV ){
103 hvname = HvNAME(CvSTASH(sv));
104 len += strlen( hvname ) + 2; /* +2 for more ::'s */
108 croak( "DProf prof_mark() lost on supposed CODE ref %s.\n", pv );
110 name = (char *)safemalloc( len * sizeof(char) + 1 );
111 strcpy( name, hvname );
112 strcat( name, "::" );
116 name = (char *)safemalloc( len * sizeof(char) + 1 );
120 profstack[profstack_ix++].ptype = ptype;
121 profstack[profstack_ix++].tms_utime = t.tms_utime;
122 profstack[profstack_ix++].tms_stime = t.tms_stime;
123 profstack[profstack_ix++].realtime = realtime;
124 profstack[profstack_ix++].name = name;
137 if( (fp = fopen( Tmon, "w" )) == NULL ){
138 warn("DProf: unable to write %s, errno = %d\n", Tmon, errno );
142 fprintf(fp, "#fOrTyTwO\n" );
143 fprintf(fp, "$hz=%d;\n", HZ );
144 fprintf(fp, "# All values are given in HZ\n" );
145 fprintf(fp, "$rrun_utime=%ld; $rrun_stime=%ld; $rrun_rtime=%ld\n",
146 prof_end.tms_utime - prof_start.tms_utime,
147 prof_end.tms_stime - prof_start.tms_stime,
148 rprof_end - rprof_start );
149 fprintf(fp, "PART2\n" );
151 while( base < profstack_ix ){
152 ptype = profstack[base++].ptype;
153 tms_utime = profstack[base++].tms_utime;
154 tms_stime = profstack[base++].tms_stime;
155 realtime = profstack[base++].realtime;
156 name = profstack[base++].name;
160 fprintf(fp,"- %ld %ld %ld %s\n",
161 tms_utime, tms_stime, realtime, name );
164 fprintf(fp,"+ %ld %ld %ld %s\n",
165 tms_utime, tms_stime, realtime, name );
168 fprintf(fp,"Profiler unknown prof code %d\n", ptype);
183 DBG_SUB_NOTIFY( "XS DBsub(%s)\n", SvPV(Sub, na) );
185 sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */
187 prof_mark( OP_ENTERSUB );
188 PUSHMARK( ORIGMARK );
190 perl_call_sv( Sub, GIMME );
192 prof_mark( OP_LEAVESUB );
198 #endif /* for_real */
202 MODULE = Devel::DProf PACKAGE = DB
209 /* SP -= items; added by xsubpp */
210 DBG_SUB_NOTIFY( "XS DBsub(%s)\n", SvPV(Sub, na) );
212 sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */
214 prof_mark( OP_ENTERSUB );
215 PUSHMARK( ORIGMARK );
217 perl_call_sv( Sub, GIMME );
219 prof_mark( OP_LEAVESUB );
221 /* PUTBACK; added by xsubpp */
226 MODULE = Devel::DProf PACKAGE = Devel::DProf
231 rprof_end = times(&prof_end);
232 DBG_TIMER_NOTIFY("Profiler timer is off.\n");
236 newXS("DB::sub", XS_DB_sub, file);
237 Sub = GvSV(DBsub); /* name of current sub */
238 sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */
239 { /* obtain name of tmon.out file */
241 sv = perl_get_sv( "DB::tmon", FALSE );
242 Tmon = (char *)safemalloc( SvCUR(sv) * sizeof(char) );
243 strcpy( Tmon, SvPVX(sv) );
245 New( 0, profstack, profstack_max, PROFANY );
246 DBG_TIMER_NOTIFY("Profiler timer is on.\n");
247 rprof_start = times(&prof_start);