1 /* XXX DProf could use some cleanups for PERL_IMPLICIT_CONTEXT */
11 # define dTHR int dummy_thr
14 /*#define DBG_SUB 1 */
15 /*#define DBG_TIMER 1 */
18 # define DBG_SUB_NOTIFY(A,B) warn( A, B )
20 # define DBG_SUB_NOTIFY(A,B) /* nothing */
24 # define DBG_TIMER_NOTIFY(A) warn( A )
26 # define DBG_TIMER_NOTIFY(A) /* nothing */
29 static U32 dprof_ticks;
31 /* HZ == clock ticks per second */
33 # define HZ ((I32)CLK_TCK)
35 # include <starlet.h> /* prototype for sys$gettim() */
36 clock_t dprof_times(struct tms *bufptr) {
39 /* Get wall time and convert to 10 ms intervals to
40 * produce the return value dprof expects */
41 # if defined(__DECC) && defined (__ALPHA)
44 _ckvmssts(sys$gettim(&vmstime));
46 retval = vmstime & 0x7fffffff;
48 /* (Older hw or ccs don't have an atomic 64-bit type, so we
49 * juggle 32-bit ints (and a float) to produce a time_t result
50 * with minimal loss of information.) */
51 long int vmstime[2],remainder,divisor = 100000;
52 _ckvmssts(sys$gettim((unsigned long int *)vmstime));
53 vmstime[1] &= 0x7fff; /* prevent overflow in EDIV */
54 _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder));
56 /* Fill in the struct tms using the CRTL routine . . .*/
57 times((tbuffer_t *)bufptr);
58 return (clock_t) retval;
60 # define Times(ptr) (dprof_times(ptr))
64 # define HZ ((I32)CLK_TCK)
69 # ifdef OS2 /* times() has significant overhead */
70 # define Times(ptr) (dprof_times(ptr))
71 # define INCL_DOSPROFILE
72 # define INCL_DOSERRORS
74 # define toLongLong(arg) (*(long long*)&(arg))
75 # define DPROF_HZ dprof_ticks
78 static long long start_cnt;
80 dprof_times(struct tms *t)
86 if (CheckOSError(DosTmrQueryFreq(&frequ)))
87 croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),na));
89 frequ = frequ/DPROF_HZ; /* count per tick */
90 if (CheckOSError(DosTmrQueryTime(&cnt)))
91 croak("DosTmrQueryTime: %s",
92 SvPV(perl_get_sv("!",TRUE),na));
93 start_cnt = toLongLong(cnt);
96 if (CheckOSError(DosTmrQueryTime(&cnt)))
97 croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE),na));
99 return (t->tms_utime = (toLongLong(cnt) - start_cnt)/frequ);
102 # define Times(ptr) (times(ptr))
107 XS(XS_Devel__DProf_END); /* used by prof_mark() */
109 static PerlIO *fp; /* pointer to tmon.out file */
112 static long TIMES_LOCATION=42;/* Where in the file to store the time totals */
113 static int SAVE_STACK = 1<<14; /* How much data to buffer until */
116 static int prof_pid; /* pid of profiled process */
118 /* Everything is built on times(2). See its manpage for a description
123 struct tms prof_start,
127 clock_t rprof_start, /* elapsed real time, in ticks */
129 wprof_u, wprof_s, wprof_r;
132 clock_t tms_utime; /* cpu time spent in user space */
133 clock_t tms_stime; /* cpu time spent in system */
134 clock_t realtime; /* elapsed real time, in ticks */
140 typedef union prof_any PROFANY;
142 static PROFANY *profstack;
143 static int profstack_max = 128;
144 static int profstack_ix = 0;
147 prof_dump(opcode ptype, char *name)
149 if(ptype == OP_LEAVESUB){
150 PerlIO_printf(fp,"- & %s\n", name );
151 } else if(ptype == OP_ENTERSUB) {
152 PerlIO_printf(fp,"+ & %s\n", name );
153 } else if(ptype == OP_DIE) {
154 PerlIO_printf(fp,"/ & %s\n", name );
156 PerlIO_printf(fp,"Profiler unknown prof code %d\n", ptype);
162 prof_dumpa(opcode ptype, U32 id)
164 if(ptype == OP_LEAVESUB){
165 PerlIO_printf(fp,"- %"UVxf"\n", (UV)id );
166 } else if(ptype == OP_ENTERSUB) {
167 PerlIO_printf(fp,"+ %"UVxf"\n", (UV)id );
168 } else if(ptype == OP_GOTO) {
169 PerlIO_printf(fp,"* %"UVxf"\n", (UV)id );
170 } else if(ptype == OP_DIE) {
171 PerlIO_printf(fp,"/ %"UVxf"\n", (UV)id );
173 PerlIO_printf(fp,"Profiler unknown prof code %d\n", ptype);
178 prof_dumps(U32 id, char *pname, char *gname)
180 PerlIO_printf(fp,"& %"UVxf" %s %s\n", (UV)id, pname, gname);
183 static clock_t otms_utime, otms_stime, orealtime;
186 prof_dumpt(long tms_utime, long tms_stime, long realtime)
188 PerlIO_printf(fp,"@ %ld %ld %ld\n", tms_utime, tms_stime, realtime);
192 prof_dump_until(long ix)
196 clock_t realtime1, realtime2;
198 realtime1 = Times(&t1);
201 opcode ptype = profstack[base++].ptype;
202 if (ptype == OP_TIME) {
203 long tms_utime = profstack[base++].tms_utime;
204 long tms_stime = profstack[base++].tms_stime;
205 long realtime = profstack[base++].realtime;
207 prof_dumpt(tms_utime, tms_stime, realtime);
208 } else if (ptype == OP_GV) {
209 U32 id = profstack[base++].id;
210 char *pname = profstack[base++].name;
211 char *gname = profstack[base++].name;
213 prof_dumps(id, pname, gname);
215 #ifdef PERLDBf_NONAME
216 U32 id = profstack[base++].id;
217 prof_dumpa(ptype, id);
219 char *name = profstack[base++].name;
220 prof_dump(ptype, name);
225 realtime2 = Times(&t2);
226 if (realtime2 != realtime1 || t1.tms_utime != t2.tms_utime
227 || t1.tms_stime != t2.tms_stime) {
228 wprof_r += realtime2 - realtime1;
229 wprof_u += t2.tms_utime - t1.tms_utime;
230 wprof_s += t2.tms_stime - t1.tms_stime;
232 PerlIO_printf(fp,"+ & Devel::DProf::write\n" );
233 PerlIO_printf(fp,"@ %"IVdf" %"IVdf" %"IVdf"\n",
234 /* The (IV) casts are one possibility:
235 * the Painfully Correct Way would be to
237 (IV)(t2.tms_utime - t1.tms_utime),
238 (IV)(t2.tms_stime - t1.tms_stime),
239 (IV)(realtime2 - realtime1));
240 PerlIO_printf(fp,"- & Devel::DProf::write\n" );
241 otms_utime = t2.tms_utime;
242 otms_stime = t2.tms_stime;
243 orealtime = realtime2;
249 static U32 total = 0;
252 prof_mark( opcode ptype )
255 clock_t realtime, rdelta, udelta, sdelta;
261 SV *Sub = GvSV(DBsub); /* name of current sub */
264 if( profstack_ix + 5 > profstack_max ){
265 profstack_max = profstack_max * 3 / 2;
266 Renew( profstack, profstack_max, PROFANY );
270 realtime = Times(&t);
271 rdelta = realtime - orealtime;
272 udelta = t.tms_utime - otms_utime;
273 sdelta = t.tms_stime - otms_stime;
274 if (rdelta || udelta || sdelta) {
276 profstack[profstack_ix++].ptype = OP_TIME;
277 profstack[profstack_ix++].tms_utime = udelta;
278 profstack[profstack_ix++].tms_stime = sdelta;
279 profstack[profstack_ix++].realtime = rdelta;
280 } else { /* Write it to disk now so's not to eat up core */
281 if (prof_pid == (int)getpid()) {
282 prof_dumpt(udelta, sdelta, rdelta);
286 orealtime = realtime;
287 otms_stime = t.tms_stime;
288 otms_utime = t.tms_utime;
291 #ifdef PERLDBf_NONAME
299 cv = INT2PTR(CV*,SvIVX(Sub));
300 svp = hv_fetch(cv_hash, (char*)&cv, sizeof(CV*), TRUE);
304 sv_setiv(*svp, id = ++lastid);
305 pname = ((GvSTASH(gv) && HvNAME(GvSTASH(gv)))
306 ? HvNAME(GvSTASH(gv))
309 if (CvXSUB(cv) == XS_Devel__DProf_END)
311 if (SAVE_STACK) { /* Store it for later recording -JH */
312 profstack[profstack_ix++].ptype = OP_GV;
313 profstack[profstack_ix++].id = id;
314 profstack[profstack_ix++].name = pname;
315 profstack[profstack_ix++].name = gname;
316 } else { /* Write it to disk now so's not to eat up core */
318 /* Only record the parent's info */
319 if (prof_pid == (int)getpid()) {
320 prof_dumps(id, pname, gname);
323 perldb = 0; /* Do not debug the kid. */
330 pv = SvPV( Sub, len );
333 /* Attempt to make CODE refs slightly identifiable by
334 * including their package name.
337 if( sv && SvTYPE(sv) == SVt_PVCV ){
339 hvname = HvNAME(CvSTASH(sv));
341 else if( CvXSUB(sv) == &XS_Devel__DProf_END ){
342 /*warn( "prof_mark() found dprof::end");*/
343 return; /* don't profile Devel::DProf::END */
346 croak( "DProf prof_mark() lost on CODE ref %s\n", pv );
348 len += strlen( hvname ) + 2; /* +2 for ::'s */
352 croak( "DProf prof_mark() lost on supposed CODE ref %s.\n", pv );
354 name = (char *)safemalloc( len * sizeof(char) + 1 );
355 strcpy( name, hvname );
356 strcat( name, "::" );
360 if( *(pv+len-1) == 'D' ){
361 /* It could be an &AUTOLOAD. */
363 /* I measured a bunch of *.pl and *.pm (from Perl
364 * distribution and other misc things) and found
365 * 780 fully-qualified names. They averaged
366 * about 19 chars each. Only 1 of those names
367 * ended with 'D' and wasn't an &AUTOLOAD--it
368 * was &overload::OVERLOAD.
372 if( strcmp( pv+len-9, ":AUTOLOAD" ) == 0 ){
373 /* The sub name is in $AUTOLOAD */
374 sv = perl_get_sv( pv, 0 );
376 croak("DProf prof_mark() lost on AUTOLOAD (%s).\n", pv );
379 DBG_SUB_NOTIFY( " AUTOLOAD(%s)\n", pv );
384 #endif /* PERLDBf_NONAME */
387 if (SAVE_STACK) { /* Store it for later recording -JH */
388 profstack[profstack_ix++].ptype = ptype;
389 #ifdef PERLDBf_NONAME
390 profstack[profstack_ix++].id = id;
392 profstack[profstack_ix++].name = name;
394 /* Only record the parent's info */
395 if (SAVE_STACK < profstack_ix) {
396 if (prof_pid == (int)getpid())
397 prof_dump_until(profstack_ix);
399 perldb = 0; /* Do not debug the kid. */
402 } else { /* Write it to disk now so's not to eat up core */
404 /* Only record the parent's info */
405 if (prof_pid == (int)getpid()) {
406 #ifdef PERLDBf_NONAME
407 prof_dumpa(ptype, id);
409 prof_dump(ptype, name);
413 perldb = 0; /* Do not debug the kid. */
417 static U32 default_perldb;
420 # define defstash PL_defstash
423 /* Counts overhead of prof_mark and extra XS call. */
425 test_time(clock_t *r, clock_t *u, clock_t *s)
429 CV *cv = perl_get_cv("Devel::DProf::NONESUCH_noxs", FALSE);
431 HV *oldstash = curstash;
433 clock_t realtime1, realtime2;
435 U32 ostack = SAVE_STACK;
436 U32 operldb = perldb;
438 SAVE_STACK = 1000000;
439 realtime1 = Times(&t1);
443 /* Disable debugging of perl_call_sv on second pass: */
444 curstash = (k == 0 ? defstash : debstash);
445 perldb = default_perldb;
448 profstack_ix = 0; /* Do not let the stack grow */
450 /* prof_mark( OP_ENTERSUB ); */
452 PUSHMARK( stack_sp );
453 perl_call_sv( (SV*)cv, G_SCALAR );
455 /* prof_mark( OP_LEAVESUB ); */
459 if (k == 0) { /* Put time with debugging */
460 realtime2 = Times(&t2);
461 *r = realtime2 - realtime1;
462 *u = t2.tms_utime - t1.tms_utime;
463 *s = t2.tms_stime - t1.tms_stime;
464 } else { /* Subtract time without debug */
465 realtime1 = Times(&t1);
466 *r -= realtime1 - realtime2;
467 *u -= t1.tms_utime - t2.tms_utime;
468 *s -= t1.tms_stime - t2.tms_stime;
478 prof_recordheader(void)
482 /* fp is opened in the BOOT section */
483 PerlIO_printf(fp, "#fOrTyTwO\n" );
484 PerlIO_printf(fp, "$hz=%"IVdf";\n", (IV)DPROF_HZ );
485 PerlIO_printf(fp, "$XS_VERSION='DProf %s';\n", XS_VERSION );
486 PerlIO_printf(fp, "# All values are given in HZ\n" );
487 test_time(&r, &u, &s);
489 "$over_utime=%"IVdf"; $over_stime=%"IVdf"; $over_rtime=%"IVdf";\n",
490 /* The (IV) casts are one possibility:
491 * the Painfully Correct Way would be to
493 (IV)u, (IV)s, (IV)r);
494 PerlIO_printf(fp, "$over_tests=10000;\n");
496 TIMES_LOCATION = PerlIO_tell(fp);
498 /* Pad with whitespace. */
499 /* This should be enough even for very large numbers. */
500 PerlIO_printf(fp, "%*s\n", 240 , "");
502 PerlIO_printf(fp, "\n");
503 PerlIO_printf(fp, "PART2\n" );
511 /* fp is opened in the BOOT section */
513 /* Now that we know the runtimes, fill them in at the recorded
519 prof_dump_until(profstack_ix);
521 PerlIO_seek(fp, TIMES_LOCATION, SEEK_SET);
522 /* Write into reserved 240 bytes: */
524 "$rrun_utime=%"IVdf"; $rrun_stime=%"IVdf"; $rrun_rtime=%"IVdf";",
525 /* The (IV) casts are one possibility:
526 * the Painfully Correct Way would be to
528 (IV)(prof_end.tms_utime-prof_start.tms_utime-wprof_u),
529 (IV)(prof_end.tms_stime-prof_start.tms_stime-wprof_s),
530 (IV)(rprof_end-rprof_start-wprof_r) );
531 PerlIO_printf(fp, "\n$total_marks=%"IVdf, (IV)total);
538 static U32 depth = 0;
541 check_depth(pTHX_ void *foo)
543 U32 need_depth = (U32)foo;
544 if (need_depth != depth) {
545 if (need_depth > depth) {
546 warn("garbled call depth when profiling");
548 I32 marks = depth - need_depth;
550 /* warn("Check_depth: got %d, expected %d\n", depth, need_depth); */
566 HV *oldstash = curstash;
567 SV *Sub = GvSV(DBsub); /* name of current sub */
571 DBG_SUB_NOTIFY( "XS DBsub(%s)\n", SvPV(Sub, na) );
573 #ifndef PERLDBf_NONAME /* Was needed on older Perls */
574 sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */
577 SAVEDESTRUCTOR_X(check_depth, (void*)depth);
580 prof_mark( OP_ENTERSUB );
581 PUSHMARK( ORIGMARK );
584 perl_call_sv( INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG);
586 curstash = debstash; /* To disable debugging of perl_call_sv */
587 #ifdef PERLDBf_NONAME
588 perl_call_sv( (SV*)SvIV(Sub), GIMME );
590 perl_call_sv( Sub, GIMME );
595 prof_mark( OP_LEAVESUB );
605 prof_mark( OP_GOTO );
609 #endif /* for_real */
613 MODULE = Devel::DProf PACKAGE = DB
620 HV *oldstash = curstash;
621 SV *Sub = GvSV(DBsub); /* name of current sub */
622 /* SP -= items; added by xsubpp */
623 DBG_SUB_NOTIFY( "XS DBsub(%s)\n", SvPV(Sub, na) );
625 sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */
627 prof_mark( OP_ENTERSUB );
628 PUSHMARK( ORIGMARK );
630 curstash = debstash; /* To disable debugging of perl_call_sv
632 perl_call_sv( Sub, GIMME );
635 prof_mark( OP_LEAVESUB );
637 /* PUTBACK; added by xsubpp */
641 MODULE = Devel::DProf PACKAGE = Devel::DProf
647 /* maybe the process forked--we want only
648 * the parent's profile.
650 if( prof_pid == (int)getpid() ){
651 rprof_end = Times(&prof_end);
652 DBG_TIMER_NOTIFY("Profiler timer is off.\n");
661 /* Before we go anywhere make sure we were invoked
662 * properly, else we'll dump core.
665 croak("DProf: run perl with -d to use DProf.\n");
667 /* When we hook up the XS DB::sub we'll be redefining
668 * the DB::sub from the PM file. Turn off warnings
672 I32 warn_tmp = dowarn;
674 newXS("DB::sub", XS_DB_sub, file);
675 newXS("DB::goto", XS_DB_goto, file);
679 sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */
682 char *buffer = getenv("PERL_DPROF_BUFFER");
685 SAVE_STACK = atoi(buffer);
688 buffer = getenv("PERL_DPROF_TICKS");
691 dprof_ticks = atoi(buffer); /* Used under OS/2 only */
697 if( (fp = PerlIO_open( "tmon.out", "w" )) == NULL )
698 croak("DProf: unable to write tmon.out, errno = %d\n", errno );
699 #ifdef PERLDBf_NONAME
700 default_perldb = PERLDBf_NONAME | PERLDBf_SUB; /* no name needed. */
702 default_perldb = default_perldb | PERLDBf_GOTO;
707 default_perldb = PERLDBf_SUB; /* debug subroutines only. */
710 prof_pid = (int)getpid();
712 New( 0, profstack, profstack_max, PROFANY );
716 DBG_TIMER_NOTIFY("Profiler timer is on.\n");
717 orealtime = rprof_start = Times(&prof_start);
718 otms_utime = prof_start.tms_utime;
719 otms_stime = prof_start.tms_stime;
720 perldb = default_perldb;