1 #define PERL_NO_GET_CONTEXT
6 /* define DBG_SUB to cause a warning on each subroutine entry. */
9 /* define DBG_TIMER to cause a warning when the timer is turned on and off. */
10 /*#define DBG_TIMER 1 */
13 #define ASSERT(x) assert(x)
19 db_get_cv(pTHX_ SV *sv)
23 if (SvIOK(sv)) { /* if (PERLDB_SUB_NN) { */
24 cv = INT2PTR(CV*,SvIVX(sv));
28 const char *const name = SvPV(sv, len);
29 cv = get_cvn_flags(name, len, GV_ADD | SvUTF8(sv));
30 } else if (SvROK(sv)) {
33 croak("DProf: don't know what subroutine to profile");
40 # define DBG_SUB_NOTIFY(A) dprof_dbg_sub_notify(aTHX_ A)
42 dprof_dbg_sub_notify(pTHX_ SV *Sub) {
43 CV * const cv = db_get_cv(aTHX_ Sub);
44 GV * const gv = cv ? CvGV(cv) : NULL;
46 warn("XS DBsub(%s::%s)\n",
47 ((GvSTASH(gv) && HvNAME_get(GvSTASH(gv))) ?
48 HvNAME_get(GvSTASH(gv)) : "(null)"),
51 warn("XS DBsub(unknown) at %x", Sub);
55 # define DBG_SUB_NOTIFY(A) /* nothing */
60 # define DBG_TIMER_NOTIFY(A) warn(A)
62 # define DBG_TIMER_NOTIFY(A) /* nothing */
65 /* HZ == clock ticks per second */
67 # define HZ ((I32)CLK_TCK)
69 # include <starlet.h> /* prototype for sys$gettim() */
70 # include <lib$routines.h>
71 # define Times(ptr) (dprof_times(aTHX_ ptr))
72 # define NEEDS_DPROF_TIMES
75 # define Times(ptr) (dprof_times(aTHX_ ptr))
76 # define NEEDS_DPROF_TIMES
82 # define HZ ((I32)CLK_TCK)
87 # ifdef OS2 /* times() has significant overhead */
88 # define Times(ptr) (dprof_times(aTHX_ ptr))
89 # define NEEDS_DPROF_TIMES
90 # define INCL_DOSPROFILE
91 # define INCL_DOSERRORS
93 # define toLongLong(arg) (*(long long*)&(arg))
94 # define DPROF_HZ g_dprof_ticks
96 # define Times(ptr) (times(ptr))
102 XS(XS_Devel__DProf_END); /* used by prof_mark() */
104 /* Everything is built on times(2). See its manpage for a description
109 clock_t tms_utime; /* cpu time spent in user space */
110 clock_t tms_stime; /* cpu time spent in system */
111 clock_t realtime; /* elapsed real time, in ticks */
117 typedef union prof_any PROFANY;
121 const char* out_file_name; /* output file (defaults to tmon.out) */
122 PerlIO* fp; /* pointer to tmon.out file */
123 Off_t TIMES_LOCATION; /* Where in the file to store the time totals */
124 int SAVE_STACK; /* How much data to buffer until end of run */
125 int prof_pid; /* pid of profiled process */
126 struct tms prof_start;
128 clock_t rprof_start; /* elapsed real time ticks */
139 HV* cv_hash; /* cache of CV to identifier mappings */
140 SV* key_hash; /* key for cv_hash */
149 #ifdef PERL_IMPLICIT_CONTEXT
150 PerlInterpreter *my_perl;
154 prof_state_t g_prof_state;
156 #define g_dprof_ticks g_prof_state.dprof_ticks
157 #define g_out_file_name g_prof_state.out_file_name
158 #define g_fp g_prof_state.fp
159 #define g_TIMES_LOCATION g_prof_state.TIMES_LOCATION
160 #define g_SAVE_STACK g_prof_state.SAVE_STACK
161 #define g_prof_pid g_prof_state.prof_pid
162 #define g_prof_start g_prof_state.prof_start
163 #define g_prof_end g_prof_state.prof_end
164 #define g_rprof_start g_prof_state.rprof_start
165 #define g_rprof_end g_prof_state.rprof_end
166 #define g_wprof_u g_prof_state.wprof_u
167 #define g_wprof_s g_prof_state.wprof_s
168 #define g_wprof_r g_prof_state.wprof_r
169 #define g_otms_utime g_prof_state.otms_utime
170 #define g_otms_stime g_prof_state.otms_stime
171 #define g_orealtime g_prof_state.orealtime
172 #define g_profstack g_prof_state.profstack
173 #define g_profstack_max g_prof_state.profstack_max
174 #define g_profstack_ix g_prof_state.profstack_ix
175 #define g_cv_hash g_prof_state.cv_hash
176 #define g_key_hash g_prof_state.key_hash
177 #define g_total g_prof_state.total
178 #define g_lastid g_prof_state.lastid
179 #define g_default_perldb g_prof_state.default_perldb
180 #define g_depth g_prof_state.depth
181 #ifdef PERL_IMPLICIT_CONTEXT
182 # define g_THX g_prof_state.my_perl
185 # define g_frequ g_prof_state.frequ
186 # define g_start_cnt g_prof_state.start_cnt
189 #ifdef NEEDS_DPROF_TIMES
191 dprof_times(pTHX_ struct tms *t)
198 if (CheckOSError(DosTmrQueryFreq(&g_frequ)))
199 croak("DosTmrQueryFreq: %s", SvPV_nolen(perl_get_sv("!",GV_ADD)));
201 g_frequ = g_frequ/DPROF_HZ; /* count per tick */
202 if (CheckOSError(DosTmrQueryTime(&cnt)))
203 croak("DosTmrQueryTime: %s",
204 SvPV_nolen_const(perl_get_sv("!",GV_ADD)));
205 g_start_cnt = toLongLong(cnt);
208 if (CheckOSError(DosTmrQueryTime(&cnt)))
209 croak("DosTmrQueryTime: %s", SvPV_nolen(perl_get_sv("!",GV_ADD)));
211 return (t->tms_utime = (toLongLong(cnt) - g_start_cnt)/g_frequ);
215 /* Get wall time and convert to 10 ms intervals to
216 * produce the return value dprof expects */
217 # if defined(__DECC) && defined (__ALPHA)
220 _ckvmssts(sys$gettim(&vmstime));
222 retval = vmstime & 0x7fffffff;
224 /* (Older hw or ccs don't have an atomic 64-bit type, so we
225 * juggle 32-bit ints (and a float) to produce a time_t result
226 * with minimal loss of information.) */
227 long int vmstime[2],remainder,divisor = 100000;
228 _ckvmssts(sys$gettim((unsigned long int *)vmstime));
229 vmstime[1] &= 0x7fff; /* prevent overflow in EDIV */
230 _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder));
232 /* Fill in the struct tms using the CRTL routine . . .*/
233 times((tbuffer_t *)t);
234 return (clock_t) retval;
235 # else /* !VMS && !OS2 */
237 # include <sys/resource.h>
240 /* Measure offset from start time to avoid overflow */
241 static struct timeval tv0 = { 0, 0 };
244 if (gettimeofday(&tv0, NULL) < 0)
245 croak("gettimeofday: %s", SvPV_nolen_const(perl_get_sv("!",GV_ADD)));
247 if (getrusage(0, &ru) < 0)
248 croak("getrusage: %s", SvPV_nolen_const(perl_get_sv("!",GV_ADD)));
250 if (gettimeofday(&tv, NULL) < 0)
251 croak("gettimeofday: %s", SvPV_nolen_const(perl_get_sv("!",GV_ADD)));
253 t->tms_stime = DPROF_HZ * ru.ru_stime.tv_sec + ru.ru_stime.tv_usec;
254 t->tms_utime = DPROF_HZ * ru.ru_utime.tv_sec + ru.ru_utime.tv_usec;
256 if (tv.tv_usec < tv0.tv_usec)
257 tv.tv_sec--, tv.tv_usec += DPROF_HZ;
259 return DPROF_HZ * (tv.tv_sec - tv0.tv_sec) + tv.tv_usec - tv0.tv_usec;
260 # else /* !VMS && !OS2 && !BSD! */
269 prof_dumpa(pTHX_ opcode ptype, U32 id)
271 if (ptype == OP_LEAVESUB) {
272 PerlIO_printf(g_fp,"- %"UVxf"\n", (UV)id);
274 else if(ptype == OP_ENTERSUB) {
275 PerlIO_printf(g_fp,"+ %"UVxf"\n", (UV)id);
277 else if(ptype == OP_GOTO) {
278 PerlIO_printf(g_fp,"* %"UVxf"\n", (UV)id);
280 else if(ptype == OP_DIE) {
281 PerlIO_printf(g_fp,"/ %"UVxf"\n", (UV)id);
284 PerlIO_printf(g_fp,"Profiler unknown prof code %d\n", ptype);
289 prof_dumps(pTHX_ U32 id, const char *pname, const char *gname)
291 PerlIO_printf(g_fp,"& %"UVxf" %s %s\n", (UV)id, pname, gname);
295 prof_dumpt(pTHX_ long tms_utime, long tms_stime, long realtime)
297 PerlIO_printf(g_fp,"@ %ld %ld %ld\n", tms_utime, tms_stime, realtime);
301 prof_dump_until(pTHX_ long ix)
307 const clock_t realtime1 = Times(&t1);
310 const opcode ptype = g_profstack[base++].ptype;
311 if (ptype == OP_TIME) {
312 const long tms_utime = g_profstack[base++].tms_utime;
313 const long tms_stime = g_profstack[base++].tms_stime;
314 const long realtime = g_profstack[base++].realtime;
316 prof_dumpt(aTHX_ tms_utime, tms_stime, realtime);
318 else if (ptype == OP_GV) {
319 const U32 id = g_profstack[base++].id;
320 const char * const pname = g_profstack[base++].name;
321 const char * const gname = g_profstack[base++].name;
323 prof_dumps(aTHX_ id, pname, gname);
326 const U32 id = g_profstack[base++].id;
327 prof_dumpa(aTHX_ ptype, id);
331 realtime2 = Times(&t2);
332 if (realtime2 != realtime1 || t1.tms_utime != t2.tms_utime
333 || t1.tms_stime != t2.tms_stime) {
334 g_wprof_r += realtime2 - realtime1;
335 g_wprof_u += t2.tms_utime - t1.tms_utime;
336 g_wprof_s += t2.tms_stime - t1.tms_stime;
338 PerlIO_printf(g_fp,"+ & Devel::DProf::write\n");
339 PerlIO_printf(g_fp,"@ %"IVdf" %"IVdf" %"IVdf"\n",
340 /* The (IV) casts are one possibility:
341 * the Painfully Correct Way would be to
343 (IV)(t2.tms_utime - t1.tms_utime),
344 (IV)(t2.tms_stime - t1.tms_stime),
345 (IV)(realtime2 - realtime1));
346 PerlIO_printf(g_fp,"- & Devel::DProf::write\n");
347 g_otms_utime = t2.tms_utime;
348 g_otms_stime = t2.tms_stime;
349 g_orealtime = realtime2;
355 set_cv_key(pTHX_ CV *cv, const char *pname, const char *gname)
357 SvGROW(g_key_hash, sizeof(CV**) + strlen(pname) + strlen(gname) + 3);
358 sv_setpvn(g_key_hash, (char*)&cv, sizeof(CV**));
359 sv_catpv(g_key_hash, pname);
360 sv_catpv(g_key_hash, "::");
361 sv_catpv(g_key_hash, gname);
365 prof_mark(pTHX_ opcode ptype)
368 clock_t realtime, rdelta, udelta, sdelta;
370 SV * const Sub = GvSV(PL_DBsub); /* name of current sub */
373 if (g_profstack_ix + 10 > g_profstack_max) {
374 g_profstack_max = g_profstack_max * 3 / 2;
375 Renew(g_profstack, g_profstack_max, PROFANY);
379 realtime = Times(&t);
380 rdelta = realtime - g_orealtime;
381 udelta = t.tms_utime - g_otms_utime;
382 sdelta = t.tms_stime - g_otms_stime;
383 if (rdelta || udelta || sdelta) {
385 ASSERT(g_profstack_ix + 4 <= g_profstack_max);
386 g_profstack[g_profstack_ix++].ptype = OP_TIME;
387 g_profstack[g_profstack_ix++].tms_utime = udelta;
388 g_profstack[g_profstack_ix++].tms_stime = sdelta;
389 g_profstack[g_profstack_ix++].realtime = rdelta;
391 else { /* Write it to disk now so's not to eat up core */
392 if (g_prof_pid == (int)getpid()) {
393 prof_dumpt(aTHX_ udelta, sdelta, rdelta);
397 g_orealtime = realtime;
398 g_otms_stime = t.tms_stime;
399 g_otms_utime = t.tms_utime;
406 CV * const cv = db_get_cv(aTHX_ Sub);
407 GV * const gv = CvGV(cv);
408 if (isGV_with_GP(gv)) {
409 pname = GvSTASH(gv) ? HvNAME_get(GvSTASH(gv)) : NULL;
410 pname = pname ? pname : (char *) "(null)";
413 gname = pname = (char *) "(null)";
416 set_cv_key(aTHX_ cv, pname, gname);
417 svp = hv_fetch(g_cv_hash, SvPVX_const(g_key_hash), SvCUR(g_key_hash), TRUE);
419 sv_setiv(*svp, id = ++g_lastid);
420 if (CvXSUB(cv) == XS_Devel__DProf_END)
422 if (g_SAVE_STACK) { /* Store it for later recording -JH */
423 ASSERT(g_profstack_ix + 4 <= g_profstack_max);
424 g_profstack[g_profstack_ix++].ptype = OP_GV;
425 g_profstack[g_profstack_ix++].id = id;
426 g_profstack[g_profstack_ix++].name = pname;
427 g_profstack[g_profstack_ix++].name = gname;
429 else { /* Write it to disk now so's not to eat up core */
430 /* Only record the parent's info */
431 if (g_prof_pid == (int)getpid()) {
432 prof_dumps(aTHX_ id, pname, gname);
436 PL_perldb = 0; /* Do not debug the kid. */
445 if (g_SAVE_STACK) { /* Store it for later recording -JH */
446 ASSERT(g_profstack_ix + 2 <= g_profstack_max);
447 g_profstack[g_profstack_ix++].ptype = ptype;
448 g_profstack[g_profstack_ix++].id = id;
450 /* Only record the parent's info */
451 if (g_SAVE_STACK < g_profstack_ix) {
452 if (g_prof_pid == (int)getpid())
453 prof_dump_until(aTHX_ g_profstack_ix);
455 PL_perldb = 0; /* Do not debug the kid. */
459 else { /* Write it to disk now so's not to eat up core */
461 /* Only record the parent's info */
462 if (g_prof_pid == (int)getpid()) {
463 prof_dumpa(aTHX_ ptype, id);
467 PL_perldb = 0; /* Do not debug the kid. */
471 /* Counts overhead of prof_mark and extra XS call. */
473 test_time(pTHX_ clock_t *r, clock_t *u, clock_t *s)
475 CV * const cv = get_cvs("Devel::DProf::NONESUCH_noxs", 0);
476 HV * const oldstash = PL_curstash;
478 const U32 ototal = g_total;
479 const U32 ostack = g_SAVE_STACK;
480 const U32 operldb = PL_perldb;
483 clock_t realtime1 = Times(&t1);
484 clock_t realtime2 = 0;
486 g_SAVE_STACK = 1000000;
490 /* Disable debugging of perl_call_sv on second pass: */
491 PL_curstash = (k == 0 ? PL_defstash : PL_debstash);
492 PL_perldb = g_default_perldb;
495 g_profstack_ix = 0; /* Do not let the stack grow */
497 /* prof_mark(aTHX_ OP_ENTERSUB); */
499 PUSHMARK(PL_stack_sp);
500 perl_call_sv((SV*)cv, G_SCALAR);
502 /* prof_mark(aTHX_ OP_LEAVESUB); */
505 PL_curstash = oldstash;
506 if (k == 0) { /* Put time with debugging */
507 realtime2 = Times(&t2);
508 *r = realtime2 - realtime1;
509 *u = t2.tms_utime - t1.tms_utime;
510 *s = t2.tms_stime - t1.tms_stime;
512 else { /* Subtract time without debug */
513 realtime1 = Times(&t1);
514 *r -= realtime1 - realtime2;
515 *u -= t1.tms_utime - t2.tms_utime;
516 *s -= t1.tms_stime - t2.tms_stime;
521 g_SAVE_STACK = ostack;
526 prof_recordheader(pTHX)
530 /* g_fp is opened in the BOOT section */
531 PerlIO_printf(g_fp, "#fOrTyTwO\n");
532 PerlIO_printf(g_fp, "$hz=%"IVdf";\n", (IV)DPROF_HZ);
533 PerlIO_printf(g_fp, "$XS_VERSION='DProf %s';\n", XS_VERSION);
534 PerlIO_printf(g_fp, "# All values are given in HZ\n");
535 test_time(aTHX_ &r, &u, &s);
537 "$over_utime=%"IVdf"; $over_stime=%"IVdf"; $over_rtime=%"IVdf";\n",
538 /* The (IV) casts are one possibility:
539 * the Painfully Correct Way would be to
541 (IV)u, (IV)s, (IV)r);
542 PerlIO_printf(g_fp, "$over_tests=10000;\n");
544 g_TIMES_LOCATION = PerlIO_tell(g_fp);
546 /* Pad with whitespace. */
547 /* This should be enough even for very large numbers. */
548 PerlIO_printf(g_fp, "%*s\n", 240 , "");
550 PerlIO_printf(g_fp, "\n");
551 PerlIO_printf(g_fp, "PART2\n");
559 /* g_fp is opened in the BOOT section */
561 /* Now that we know the runtimes, fill them in at the recorded
565 prof_dump_until(aTHX_ g_profstack_ix);
567 PerlIO_seek(g_fp, g_TIMES_LOCATION, SEEK_SET);
568 /* Write into reserved 240 bytes: */
570 "$rrun_utime=%"IVdf"; $rrun_stime=%"IVdf"; $rrun_rtime=%"IVdf";",
571 /* The (IV) casts are one possibility:
572 * the Painfully Correct Way would be to
574 (IV)(g_prof_end.tms_utime-g_prof_start.tms_utime-g_wprof_u),
575 (IV)(g_prof_end.tms_stime-g_prof_start.tms_stime-g_wprof_s),
576 (IV)(g_rprof_end-g_rprof_start-g_wprof_r));
577 PerlIO_printf(g_fp, "\n$total_marks=%"IVdf, (IV)g_total);
585 check_depth(pTHX_ void *foo)
587 const U32 need_depth = PTR2UV(foo);
588 if (need_depth != g_depth) {
589 if (need_depth > g_depth) {
590 warn("garbled call depth when profiling");
593 IV marks = g_depth - need_depth;
595 /* warn("Check_depth: got %d, expected %d\n", g_depth, need_depth); */
597 prof_mark(aTHX_ OP_DIE);
599 g_depth = need_depth;
612 SV * const Sub = GvSV(PL_DBsub); /* name of current sub */
614 #ifdef PERL_IMPLICIT_CONTEXT
615 /* profile only the interpreter that loaded us */
618 perl_call_sv((SV*)db_get_cv(aTHX_ Sub), GIMME_V | G_NODEBUG);
623 HV * const oldstash = PL_curstash;
624 const I32 old_scopestack_ix = PL_scopestack_ix;
625 const I32 old_cxstack_ix = cxstack_ix;
629 SAVEDESTRUCTOR_X(check_depth, INT2PTR(void*,g_depth));
632 prof_mark(aTHX_ OP_ENTERSUB);
634 perl_call_sv((SV*)db_get_cv(aTHX_ Sub), GIMME_V | G_NODEBUG);
635 PL_curstash = oldstash;
637 /* Make sure we are on the same context and scope as before the call
638 * to the sub. If the called sub was exited via a goto, next or
639 * last then this will try to croak(), however perl may still crash
640 * with a segfault. */
641 if (PL_scopestack_ix != old_scopestack_ix || cxstack_ix != old_cxstack_ix)
642 croak("panic: Devel::DProf inconsistent subroutine return");
644 prof_mark(aTHX_ OP_LEAVESUB);
653 #ifdef PERL_IMPLICIT_CONTEXT
657 prof_mark(aTHX_ OP_GOTO);
662 #endif /* for_real */
666 MODULE = Devel::DProf PACKAGE = DB
673 HV * const oldstash = PL_curstash;
674 SV * const Sub = GvSV(PL_DBsub); /* name of current sub */
675 /* SP -= items; added by xsubpp */
678 sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */
680 prof_mark(aTHX_ OP_ENTERSUB);
683 PL_curstash = PL_debstash; /* To disable debugging of perl_call_sv */
684 perl_call_sv(Sub, GIMME_V);
685 PL_curstash = oldstash;
687 prof_mark(aTHX_ OP_LEAVESUB);
689 /* PUTBACK; added by xsubpp */
694 MODULE = Devel::DProf PACKAGE = Devel::DProf
701 /* maybe the process forked--we want only
702 * the parent's profile.
705 #ifdef PERL_IMPLICIT_CONTEXT
708 g_prof_pid == (int)getpid())
710 g_rprof_end = Times(&g_prof_end);
711 DBG_TIMER_NOTIFY("Profiler timer is off.\n");
722 g_TIMES_LOCATION = 42;
723 g_SAVE_STACK = 1<<14;
724 g_profstack_max = 128;
725 #ifdef PERL_IMPLICIT_CONTEXT
729 /* Before we go anywhere make sure we were invoked
730 * properly, else we'll dump core.
733 croak("DProf: run perl with -d to use DProf.\n");
735 /* When we hook up the XS DB::sub we'll be redefining
736 * the DB::sub from the PM file. Turn off warnings
740 const bool warn_tmp = PL_dowarn;
742 newXS("DB::sub", XS_DB_sub, file);
743 newXS("DB::goto", XS_DB_goto, file);
744 PL_dowarn = warn_tmp;
747 sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */
750 const char *buffer = getenv("PERL_DPROF_BUFFER");
753 g_SAVE_STACK = atoi(buffer);
756 buffer = getenv("PERL_DPROF_TICKS");
759 g_dprof_ticks = atoi(buffer); /* Used under OS/2 only */
765 buffer = getenv("PERL_DPROF_OUT_FILE_NAME");
766 g_out_file_name = savepv(buffer ? buffer : "tmon.out");
769 if ((g_fp = PerlIO_open(g_out_file_name, "w")) == NULL)
770 croak("DProf: unable to write '%s', errno = %d\n",
771 g_out_file_name, errno);
773 g_default_perldb = PERLDBf_NONAME | PERLDBf_SUB | PERLDBf_GOTO;
775 g_key_hash = newSV(256);
776 g_prof_pid = (int)getpid();
778 Newx(g_profstack, g_profstack_max, PROFANY);
779 prof_recordheader(aTHX);
780 DBG_TIMER_NOTIFY("Profiler timer is on.\n");
781 g_orealtime = g_rprof_start = Times(&g_prof_start);
782 g_otms_utime = g_prof_start.tms_utime;
783 g_otms_stime = g_prof_start.tms_stime;
784 PL_perldb = g_default_perldb;