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 # define DBG_SUB_NOTIFY(A) dprof_dbg_sub_notify(A)
21 dprof_dbg_sub_notify(SV *Sub) {
22 CV *cv = INT2PTR(CV*,SvIVX(Sub));
23 GV *gv = cv ? CvGV(cv) : NULL;
25 warn("XS DBsub(%s::%s)\n",
26 ((GvSTASH(gv) && HvNAME(GvSTASH(gv))) ?
27 HvNAME(GvSTASH(gv)) : "(null)"),
30 warn("XS DBsub(unknown) at %x", Sub);
34 # define DBG_SUB_NOTIFY(A) /* nothing */
39 # define DBG_TIMER_NOTIFY(A) warn(A)
41 # define DBG_TIMER_NOTIFY(A) /* nothing */
44 /* HZ == clock ticks per second */
46 # define HZ ((I32)CLK_TCK)
48 # include <starlet.h> /* prototype for sys$gettim() */
49 # include <lib$routines.h>
50 # define Times(ptr) (dprof_times(aTHX_ ptr))
54 # define HZ ((I32)CLK_TCK)
59 # ifdef OS2 /* times() has significant overhead */
60 # define Times(ptr) (dprof_times(aTHX_ ptr))
61 # define INCL_DOSPROFILE
62 # define INCL_DOSERRORS
64 # define toLongLong(arg) (*(long long*)&(arg))
65 # define DPROF_HZ g_dprof_ticks
67 # define Times(ptr) (times(ptr))
72 XS(XS_Devel__DProf_END); /* used by prof_mark() */
74 /* Everything is built on times(2). See its manpage for a description
79 clock_t tms_utime; /* cpu time spent in user space */
80 clock_t tms_stime; /* cpu time spent in system */
81 clock_t realtime; /* elapsed real time, in ticks */
87 typedef union prof_any PROFANY;
91 char* out_file_name; /* output file (defaults to tmon.out) */
92 PerlIO* fp; /* pointer to tmon.out file */
93 Off_t TIMES_LOCATION; /* Where in the file to store the time totals */
94 int SAVE_STACK; /* How much data to buffer until end of run */
95 int prof_pid; /* pid of profiled process */
96 struct tms prof_start;
98 clock_t rprof_start; /* elapsed real time ticks */
118 #ifdef PERL_IMPLICIT_CONTEXT
125 prof_state_t g_prof_state;
127 #define g_dprof_ticks g_prof_state.dprof_ticks
128 #define g_out_file_name g_prof_state.out_file_name
129 #define g_fp g_prof_state.fp
130 #define g_TIMES_LOCATION g_prof_state.TIMES_LOCATION
131 #define g_SAVE_STACK g_prof_state.SAVE_STACK
132 #define g_prof_pid g_prof_state.prof_pid
133 #define g_prof_start g_prof_state.prof_start
134 #define g_prof_end g_prof_state.prof_end
135 #define g_rprof_start g_prof_state.rprof_start
136 #define g_rprof_end g_prof_state.rprof_end
137 #define g_wprof_u g_prof_state.wprof_u
138 #define g_wprof_s g_prof_state.wprof_s
139 #define g_wprof_r g_prof_state.wprof_r
140 #define g_otms_utime g_prof_state.otms_utime
141 #define g_otms_stime g_prof_state.otms_stime
142 #define g_orealtime g_prof_state.orealtime
143 #define g_profstack g_prof_state.profstack
144 #define g_profstack_max g_prof_state.profstack_max
145 #define g_profstack_ix g_prof_state.profstack_ix
146 #define g_cv_hash g_prof_state.cv_hash
147 #define g_total g_prof_state.total
148 #define g_lastid g_prof_state.lastid
149 #define g_default_perldb g_prof_state.default_perldb
150 #define g_depth g_prof_state.depth
151 #ifdef PERL_IMPLICIT_CONTEXT
152 # define g_THX g_prof_state.aTHX
155 # define g_frequ g_prof_state.frequ
156 # define g_start_cnt g_prof_state.start_cnt
160 dprof_times(pTHX_ struct tms *t)
168 if (CheckOSError(DosTmrQueryFreq(&g_frequ)))
169 croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),n_a));
171 g_frequ = g_frequ/DPROF_HZ; /* count per tick */
172 if (CheckOSError(DosTmrQueryTime(&cnt)))
173 croak("DosTmrQueryTime: %s",
174 SvPV(perl_get_sv("!",TRUE), n_a));
175 g_start_cnt = toLongLong(cnt);
178 if (CheckOSError(DosTmrQueryTime(&cnt)))
179 croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE), n_a));
181 return (t->tms_utime = (toLongLong(cnt) - g_start_cnt)/g_frequ);
185 /* Get wall time and convert to 10 ms intervals to
186 * produce the return value dprof expects */
187 # if defined(__DECC) && defined (__ALPHA)
190 _ckvmssts(sys$gettim(&vmstime));
192 retval = vmstime & 0x7fffffff;
194 /* (Older hw or ccs don't have an atomic 64-bit type, so we
195 * juggle 32-bit ints (and a float) to produce a time_t result
196 * with minimal loss of information.) */
197 long int vmstime[2],remainder,divisor = 100000;
198 _ckvmssts(sys$gettim((unsigned long int *)vmstime));
199 vmstime[1] &= 0x7fff; /* prevent overflow in EDIV */
200 _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder));
202 /* Fill in the struct tms using the CRTL routine . . .*/
203 times((tbuffer_t *)t);
204 return (clock_t) retval;
205 # else /* !VMS && !OS2 */
212 prof_dumpa(pTHX_ opcode ptype, U32 id)
214 if (ptype == OP_LEAVESUB) {
215 PerlIO_printf(g_fp,"- %"UVxf"\n", (UV)id);
217 else if(ptype == OP_ENTERSUB) {
218 PerlIO_printf(g_fp,"+ %"UVxf"\n", (UV)id);
220 else if(ptype == OP_GOTO) {
221 PerlIO_printf(g_fp,"* %"UVxf"\n", (UV)id);
223 else if(ptype == OP_DIE) {
224 PerlIO_printf(g_fp,"/ %"UVxf"\n", (UV)id);
227 PerlIO_printf(g_fp,"Profiler unknown prof code %d\n", ptype);
232 prof_dumps(pTHX_ U32 id, char *pname, char *gname)
234 PerlIO_printf(g_fp,"& %"UVxf" %s %s\n", (UV)id, pname, gname);
238 prof_dumpt(pTHX_ long tms_utime, long tms_stime, long realtime)
240 PerlIO_printf(g_fp,"@ %ld %ld %ld\n", tms_utime, tms_stime, realtime);
244 prof_dump_until(pTHX_ long ix)
248 clock_t realtime1, realtime2;
250 realtime1 = Times(&t1);
253 opcode ptype = g_profstack[base++].ptype;
254 if (ptype == OP_TIME) {
255 long tms_utime = g_profstack[base++].tms_utime;
256 long tms_stime = g_profstack[base++].tms_stime;
257 long realtime = g_profstack[base++].realtime;
259 prof_dumpt(aTHX_ tms_utime, tms_stime, realtime);
261 else if (ptype == OP_GV) {
262 U32 id = g_profstack[base++].id;
263 char *pname = g_profstack[base++].name;
264 char *gname = g_profstack[base++].name;
266 prof_dumps(aTHX_ id, pname, gname);
269 U32 id = g_profstack[base++].id;
270 prof_dumpa(aTHX_ ptype, id);
274 realtime2 = Times(&t2);
275 if (realtime2 != realtime1 || t1.tms_utime != t2.tms_utime
276 || t1.tms_stime != t2.tms_stime) {
277 g_wprof_r += realtime2 - realtime1;
278 g_wprof_u += t2.tms_utime - t1.tms_utime;
279 g_wprof_s += t2.tms_stime - t1.tms_stime;
281 PerlIO_printf(g_fp,"+ & Devel::DProf::write\n");
282 PerlIO_printf(g_fp,"@ %"IVdf" %"IVdf" %"IVdf"\n",
283 /* The (IV) casts are one possibility:
284 * the Painfully Correct Way would be to
286 (IV)(t2.tms_utime - t1.tms_utime),
287 (IV)(t2.tms_stime - t1.tms_stime),
288 (IV)(realtime2 - realtime1));
289 PerlIO_printf(g_fp,"- & Devel::DProf::write\n");
290 g_otms_utime = t2.tms_utime;
291 g_otms_stime = t2.tms_stime;
292 g_orealtime = realtime2;
298 prof_mark(pTHX_ opcode ptype)
301 clock_t realtime, rdelta, udelta, sdelta;
303 SV *Sub = GvSV(PL_DBsub); /* name of current sub */
306 if (g_profstack_ix + 10 > g_profstack_max) {
307 g_profstack_max = g_profstack_max * 3 / 2;
308 Renew(g_profstack, g_profstack_max, PROFANY);
312 realtime = Times(&t);
313 rdelta = realtime - g_orealtime;
314 udelta = t.tms_utime - g_otms_utime;
315 sdelta = t.tms_stime - g_otms_stime;
316 if (rdelta || udelta || sdelta) {
318 ASSERT(g_profstack_ix + 4 <= g_profstack_max);
319 g_profstack[g_profstack_ix++].ptype = OP_TIME;
320 g_profstack[g_profstack_ix++].tms_utime = udelta;
321 g_profstack[g_profstack_ix++].tms_stime = sdelta;
322 g_profstack[g_profstack_ix++].realtime = rdelta;
324 else { /* Write it to disk now so's not to eat up core */
325 if (g_prof_pid == (int)getpid()) {
326 prof_dumpt(aTHX_ udelta, sdelta, rdelta);
330 g_orealtime = realtime;
331 g_otms_stime = t.tms_stime;
332 g_otms_utime = t.tms_utime;
340 cv = INT2PTR(CV*,SvIVX(Sub));
341 svp = hv_fetch(g_cv_hash, (char*)&cv, sizeof(CV*), TRUE);
345 sv_setiv(*svp, id = ++g_lastid);
346 pname = ((GvSTASH(gv) && HvNAME(GvSTASH(gv)))
347 ? HvNAME(GvSTASH(gv))
350 if (CvXSUB(cv) == XS_Devel__DProf_END)
352 if (g_SAVE_STACK) { /* Store it for later recording -JH */
353 ASSERT(g_profstack_ix + 4 <= g_profstack_max);
354 g_profstack[g_profstack_ix++].ptype = OP_GV;
355 g_profstack[g_profstack_ix++].id = id;
356 g_profstack[g_profstack_ix++].name = pname;
357 g_profstack[g_profstack_ix++].name = gname;
359 else { /* Write it to disk now so's not to eat up core */
360 /* Only record the parent's info */
361 if (g_prof_pid == (int)getpid()) {
362 prof_dumps(aTHX_ id, pname, gname);
366 PL_perldb = 0; /* Do not debug the kid. */
375 if (g_SAVE_STACK) { /* Store it for later recording -JH */
376 ASSERT(g_profstack_ix + 2 <= g_profstack_max);
377 g_profstack[g_profstack_ix++].ptype = ptype;
378 g_profstack[g_profstack_ix++].id = id;
380 /* Only record the parent's info */
381 if (g_SAVE_STACK < g_profstack_ix) {
382 if (g_prof_pid == (int)getpid())
383 prof_dump_until(aTHX_ g_profstack_ix);
385 PL_perldb = 0; /* Do not debug the kid. */
389 else { /* Write it to disk now so's not to eat up core */
391 /* Only record the parent's info */
392 if (g_prof_pid == (int)getpid()) {
393 prof_dumpa(aTHX_ ptype, id);
397 PL_perldb = 0; /* Do not debug the kid. */
402 # define defstash PL_defstash
405 /* Counts overhead of prof_mark and extra XS call. */
407 test_time(pTHX_ clock_t *r, clock_t *u, clock_t *s)
409 CV *cv = perl_get_cv("Devel::DProf::NONESUCH_noxs", FALSE);
411 HV *oldstash = PL_curstash;
413 clock_t realtime1 = 0, realtime2 = 0;
414 U32 ototal = g_total;
415 U32 ostack = g_SAVE_STACK;
416 U32 operldb = PL_perldb;
418 g_SAVE_STACK = 1000000;
419 realtime1 = Times(&t1);
423 /* Disable debugging of perl_call_sv on second pass: */
424 PL_curstash = (k == 0 ? PL_defstash : PL_debstash);
425 PL_perldb = g_default_perldb;
428 g_profstack_ix = 0; /* Do not let the stack grow */
430 /* prof_mark(aTHX_ OP_ENTERSUB); */
432 PUSHMARK(PL_stack_sp);
433 perl_call_sv((SV*)cv, G_SCALAR);
435 /* prof_mark(aTHX_ OP_LEAVESUB); */
438 PL_curstash = oldstash;
439 if (k == 0) { /* Put time with debugging */
440 realtime2 = Times(&t2);
441 *r = realtime2 - realtime1;
442 *u = t2.tms_utime - t1.tms_utime;
443 *s = t2.tms_stime - t1.tms_stime;
445 else { /* Subtract time without debug */
446 realtime1 = Times(&t1);
447 *r -= realtime1 - realtime2;
448 *u -= t1.tms_utime - t2.tms_utime;
449 *s -= t1.tms_stime - t2.tms_stime;
454 g_SAVE_STACK = ostack;
459 prof_recordheader(pTHX)
463 /* g_fp is opened in the BOOT section */
464 PerlIO_printf(g_fp, "#fOrTyTwO\n");
465 PerlIO_printf(g_fp, "$hz=%"IVdf";\n", (IV)DPROF_HZ);
466 PerlIO_printf(g_fp, "$XS_VERSION='DProf %s';\n", XS_VERSION);
467 PerlIO_printf(g_fp, "# All values are given in HZ\n");
468 test_time(aTHX_ &r, &u, &s);
470 "$over_utime=%"IVdf"; $over_stime=%"IVdf"; $over_rtime=%"IVdf";\n",
471 /* The (IV) casts are one possibility:
472 * the Painfully Correct Way would be to
474 (IV)u, (IV)s, (IV)r);
475 PerlIO_printf(g_fp, "$over_tests=10000;\n");
477 g_TIMES_LOCATION = PerlIO_tell(g_fp);
479 /* Pad with whitespace. */
480 /* This should be enough even for very large numbers. */
481 PerlIO_printf(g_fp, "%*s\n", 240 , "");
483 PerlIO_printf(g_fp, "\n");
484 PerlIO_printf(g_fp, "PART2\n");
492 /* g_fp is opened in the BOOT section */
494 /* Now that we know the runtimes, fill them in at the recorded
498 prof_dump_until(aTHX_ g_profstack_ix);
500 PerlIO_seek(g_fp, g_TIMES_LOCATION, SEEK_SET);
501 /* Write into reserved 240 bytes: */
503 "$rrun_utime=%"IVdf"; $rrun_stime=%"IVdf"; $rrun_rtime=%"IVdf";",
504 /* The (IV) casts are one possibility:
505 * the Painfully Correct Way would be to
507 (IV)(g_prof_end.tms_utime-g_prof_start.tms_utime-g_wprof_u),
508 (IV)(g_prof_end.tms_stime-g_prof_start.tms_stime-g_wprof_s),
509 (IV)(g_rprof_end-g_rprof_start-g_wprof_r));
510 PerlIO_printf(g_fp, "\n$total_marks=%"IVdf, (IV)g_total);
518 check_depth(pTHX_ void *foo)
520 U32 need_depth = PTR2UV(foo);
521 if (need_depth != g_depth) {
522 if (need_depth > g_depth) {
523 warn("garbled call depth when profiling");
526 IV marks = g_depth - need_depth;
528 /* warn("Check_depth: got %d, expected %d\n", g_depth, need_depth); */
530 prof_mark(aTHX_ OP_DIE);
532 g_depth = need_depth;
544 SV *Sub = GvSV(PL_DBsub); /* name of current sub */
546 #ifdef PERL_IMPLICIT_CONTEXT
547 /* profile only the interpreter that loaded us */
550 perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME_V | G_NODEBUG);
555 HV *oldstash = PL_curstash;
559 SAVEDESTRUCTOR_X(check_depth, INT2PTR(void*,g_depth));
562 prof_mark(aTHX_ OP_ENTERSUB);
564 perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME_V | G_NODEBUG);
565 PL_curstash = oldstash;
566 prof_mark(aTHX_ OP_LEAVESUB);
574 #ifdef PERL_IMPLICIT_CONTEXT
578 prof_mark(aTHX_ OP_GOTO);
583 #endif /* for_real */
587 MODULE = Devel::DProf PACKAGE = DB
594 HV *oldstash = PL_curstash;
595 SV *Sub = GvSV(PL_DBsub); /* name of current sub */
596 /* SP -= items; added by xsubpp */
599 sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */
601 prof_mark(aTHX_ OP_ENTERSUB);
604 PL_curstash = PL_debstash; /* To disable debugging of perl_call_sv */
605 perl_call_sv(Sub, GIMME_V);
606 PL_curstash = oldstash;
608 prof_mark(aTHX_ OP_LEAVESUB);
610 /* PUTBACK; added by xsubpp */
615 MODULE = Devel::DProf PACKAGE = Devel::DProf
622 /* maybe the process forked--we want only
623 * the parent's profile.
626 #ifdef PERL_IMPLICIT_CONTEXT
629 g_prof_pid == (int)getpid())
631 g_rprof_end = Times(&g_prof_end);
632 DBG_TIMER_NOTIFY("Profiler timer is off.\n");
643 g_TIMES_LOCATION = 42;
644 g_SAVE_STACK = 1<<14;
645 g_profstack_max = 128;
646 #ifdef PERL_IMPLICIT_CONTEXT
650 /* Before we go anywhere make sure we were invoked
651 * properly, else we'll dump core.
654 croak("DProf: run perl with -d to use DProf.\n");
656 /* When we hook up the XS DB::sub we'll be redefining
657 * the DB::sub from the PM file. Turn off warnings
661 bool warn_tmp = PL_dowarn;
663 newXS("DB::sub", XS_DB_sub, file);
664 newXS("DB::goto", XS_DB_goto, file);
665 PL_dowarn = warn_tmp;
668 sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */
671 char *buffer = getenv("PERL_DPROF_BUFFER");
674 g_SAVE_STACK = atoi(buffer);
677 buffer = getenv("PERL_DPROF_TICKS");
680 g_dprof_ticks = atoi(buffer); /* Used under OS/2 only */
686 buffer = getenv("PERL_DPROF_OUT_FILE_NAME");
687 g_out_file_name = savepv(buffer ? buffer : "tmon.out");
690 if ((g_fp = PerlIO_open(g_out_file_name, "w")) == NULL)
691 croak("DProf: unable to write '%s', errno = %d\n",
692 g_out_file_name, errno);
694 g_default_perldb = PERLDBf_NONAME | PERLDBf_SUB | PERLDBf_GOTO;
696 g_prof_pid = (int)getpid();
698 New(0, g_profstack, g_profstack_max, PROFANY);
699 prof_recordheader(aTHX);
700 DBG_TIMER_NOTIFY("Profiler timer is on.\n");
701 g_orealtime = g_rprof_start = Times(&g_prof_start);
702 g_otms_utime = g_prof_start.tms_utime;
703 g_otms_stime = g_prof_start.tms_stime;
704 PL_perldb = g_default_perldb;