1 #define PERL_NO_GET_CONTEXT
8 # define dTHR int dummy_thr
11 /*#define DBG_SUB 1 */
12 /*#define DBG_TIMER 1 */
15 # define DBG_SUB_NOTIFY(A,B) warn(A, B)
17 # define DBG_SUB_NOTIFY(A,B) /* nothing */
21 # define DBG_TIMER_NOTIFY(A) warn(A)
23 # define DBG_TIMER_NOTIFY(A) /* nothing */
26 /* HZ == clock ticks per second */
28 # define HZ ((I32)CLK_TCK)
30 # include <starlet.h> /* prototype for sys$gettim() */
31 # define Times(ptr) (dprof_times(aTHX_ ptr))
35 # define HZ ((I32)CLK_TCK)
40 # ifdef OS2 /* times() has significant overhead */
41 # define Times(ptr) (dprof_times(aTHX_ ptr))
42 # define INCL_DOSPROFILE
43 # define INCL_DOSERRORS
45 # define toLongLong(arg) (*(long long*)&(arg))
46 # define DPROF_HZ g_dprof_ticks
48 # define Times(ptr) (times(ptr))
53 XS(XS_Devel__DProf_END); /* used by prof_mark() */
55 /* Everything is built on times(2). See its manpage for a description
60 clock_t tms_utime; /* cpu time spent in user space */
61 clock_t tms_stime; /* cpu time spent in system */
62 clock_t realtime; /* elapsed real time, in ticks */
68 typedef union prof_any PROFANY;
72 PerlIO* fp; /* pointer to tmon.out file */
73 long TIMES_LOCATION; /* Where in the file to store the time totals */
74 int SAVE_STACK; /* How much data to buffer until end of run */
75 int prof_pid; /* pid of profiled process */
76 struct tms prof_start;
78 clock_t rprof_start; /* elapsed real time ticks */
98 #ifdef PERL_IMPLICIT_CONTEXT
105 prof_state_t g_prof_state;
107 #define g_dprof_ticks g_prof_state.dprof_ticks
108 #define g_fp g_prof_state.fp
109 #define g_TIMES_LOCATION g_prof_state.TIMES_LOCATION
110 #define g_SAVE_STACK g_prof_state.SAVE_STACK
111 #define g_prof_pid g_prof_state.prof_pid
112 #define g_prof_start g_prof_state.prof_start
113 #define g_prof_end g_prof_state.prof_end
114 #define g_rprof_start g_prof_state.rprof_start
115 #define g_rprof_end g_prof_state.rprof_end
116 #define g_wprof_u g_prof_state.wprof_u
117 #define g_wprof_s g_prof_state.wprof_s
118 #define g_wprof_r g_prof_state.wprof_r
119 #define g_otms_utime g_prof_state.otms_utime
120 #define g_otms_stime g_prof_state.otms_stime
121 #define g_orealtime g_prof_state.orealtime
122 #define g_profstack g_prof_state.profstack
123 #define g_profstack_max g_prof_state.profstack_max
124 #define g_profstack_ix g_prof_state.profstack_ix
125 #define g_cv_hash g_prof_state.cv_hash
126 #define g_total g_prof_state.total
127 #define g_lastid g_prof_state.lastid
128 #define g_default_perldb g_prof_state.default_perldb
129 #define g_depth g_prof_state.depth
130 #ifdef PERL_IMPLICIT_CONTEXT
131 # define g_THX g_prof_state.aTHX
134 # define g_frequ g_prof_state.frequ
135 # define g_start_cnt g_prof_state.start_cnt
139 dprof_times(pTHX_ struct tms *t)
146 if (CheckOSError(DosTmrQueryFreq(&g_frequ)))
147 croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),na));
149 g_frequ = g_frequ/DPROF_HZ; /* count per tick */
150 if (CheckOSError(DosTmrQueryTime(&cnt)))
151 croak("DosTmrQueryTime: %s",
152 SvPV(perl_get_sv("!",TRUE),na));
153 g_start_cnt = toLongLong(cnt);
156 if (CheckOSError(DosTmrQueryTime(&cnt)))
157 croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE),na));
159 return (t->tms_utime = (toLongLong(cnt) - g_start_cnt)/g_frequ);
163 /* Get wall time and convert to 10 ms intervals to
164 * produce the return value dprof expects */
165 # if defined(__DECC) && defined (__ALPHA)
168 _ckvmssts(sys$gettim(&vmstime));
170 retval = vmstime & 0x7fffffff;
172 /* (Older hw or ccs don't have an atomic 64-bit type, so we
173 * juggle 32-bit ints (and a float) to produce a time_t result
174 * with minimal loss of information.) */
175 long int vmstime[2],remainder,divisor = 100000;
176 _ckvmssts(sys$gettim((unsigned long int *)vmstime));
177 vmstime[1] &= 0x7fff; /* prevent overflow in EDIV */
178 _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder));
180 /* Fill in the struct tms using the CRTL routine . . .*/
181 times((tbuffer_t *)t);
182 return (clock_t) retval;
183 # else /* !VMS && !OS2 */
190 prof_dumpa(pTHX_ opcode ptype, U32 id)
192 if (ptype == OP_LEAVESUB) {
193 PerlIO_printf(g_fp,"- %"UVxf"\n", (UV)id);
195 else if(ptype == OP_ENTERSUB) {
196 PerlIO_printf(g_fp,"+ %"UVxf"\n", (UV)id);
198 else if(ptype == OP_GOTO) {
199 PerlIO_printf(g_fp,"* %"UVxf"\n", (UV)id);
201 else if(ptype == OP_DIE) {
202 PerlIO_printf(g_fp,"/ %"UVxf"\n", (UV)id);
205 PerlIO_printf(g_fp,"Profiler unknown prof code %d\n", ptype);
210 prof_dumps(pTHX_ U32 id, char *pname, char *gname)
212 PerlIO_printf(g_fp,"& %"UVxf" %s %s\n", (UV)id, pname, gname);
216 prof_dumpt(pTHX_ long tms_utime, long tms_stime, long realtime)
218 PerlIO_printf(g_fp,"@ %ld %ld %ld\n", tms_utime, tms_stime, realtime);
222 prof_dump_until(pTHX_ long ix)
226 clock_t realtime1, realtime2;
228 realtime1 = Times(&t1);
231 opcode ptype = g_profstack[base++].ptype;
232 if (ptype == OP_TIME) {
233 long tms_utime = g_profstack[base++].tms_utime;
234 long tms_stime = g_profstack[base++].tms_stime;
235 long realtime = g_profstack[base++].realtime;
237 prof_dumpt(aTHX_ tms_utime, tms_stime, realtime);
239 else if (ptype == OP_GV) {
240 U32 id = g_profstack[base++].id;
241 char *pname = g_profstack[base++].name;
242 char *gname = g_profstack[base++].name;
244 prof_dumps(aTHX_ id, pname, gname);
247 U32 id = g_profstack[base++].id;
248 prof_dumpa(aTHX_ ptype, id);
252 realtime2 = Times(&t2);
253 if (realtime2 != realtime1 || t1.tms_utime != t2.tms_utime
254 || t1.tms_stime != t2.tms_stime) {
255 g_wprof_r += realtime2 - realtime1;
256 g_wprof_u += t2.tms_utime - t1.tms_utime;
257 g_wprof_s += t2.tms_stime - t1.tms_stime;
259 PerlIO_printf(g_fp,"+ & Devel::DProf::write\n");
260 PerlIO_printf(g_fp,"@ %"IVdf" %"IVdf" %"IVdf"\n",
261 /* The (IV) casts are one possibility:
262 * the Painfully Correct Way would be to
264 (IV)(t2.tms_utime - t1.tms_utime),
265 (IV)(t2.tms_stime - t1.tms_stime),
266 (IV)(realtime2 - realtime1));
267 PerlIO_printf(g_fp,"- & Devel::DProf::write\n");
268 g_otms_utime = t2.tms_utime;
269 g_otms_stime = t2.tms_stime;
270 g_orealtime = realtime2;
276 prof_mark(pTHX_ opcode ptype)
279 clock_t realtime, rdelta, udelta, sdelta;
285 SV *Sub = GvSV(PL_DBsub); /* name of current sub */
288 if (g_profstack_ix + 5 > g_profstack_max) {
289 g_profstack_max = g_profstack_max * 3 / 2;
290 Renew(g_profstack, g_profstack_max, PROFANY);
294 realtime = Times(&t);
295 rdelta = realtime - g_orealtime;
296 udelta = t.tms_utime - g_otms_utime;
297 sdelta = t.tms_stime - g_otms_stime;
298 if (rdelta || udelta || sdelta) {
300 g_profstack[g_profstack_ix++].ptype = OP_TIME;
301 g_profstack[g_profstack_ix++].tms_utime = udelta;
302 g_profstack[g_profstack_ix++].tms_stime = sdelta;
303 g_profstack[g_profstack_ix++].realtime = rdelta;
305 else { /* Write it to disk now so's not to eat up core */
306 if (g_prof_pid == (int)getpid()) {
307 prof_dumpt(aTHX_ udelta, sdelta, rdelta);
311 g_orealtime = realtime;
312 g_otms_stime = t.tms_stime;
313 g_otms_utime = t.tms_utime;
321 cv = INT2PTR(CV*,SvIVX(Sub));
322 svp = hv_fetch(g_cv_hash, (char*)&cv, sizeof(CV*), TRUE);
326 sv_setiv(*svp, id = ++g_lastid);
327 pname = ((GvSTASH(gv) && HvNAME(GvSTASH(gv)))
328 ? HvNAME(GvSTASH(gv))
331 if (CvXSUB(cv) == XS_Devel__DProf_END)
333 if (g_SAVE_STACK) { /* Store it for later recording -JH */
334 g_profstack[g_profstack_ix++].ptype = OP_GV;
335 g_profstack[g_profstack_ix++].id = id;
336 g_profstack[g_profstack_ix++].name = pname;
337 g_profstack[g_profstack_ix++].name = gname;
339 else { /* Write it to disk now so's not to eat up core */
340 /* Only record the parent's info */
341 if (g_prof_pid == (int)getpid()) {
342 prof_dumps(aTHX_ id, pname, gname);
346 PL_perldb = 0; /* Do not debug the kid. */
355 if (g_SAVE_STACK) { /* Store it for later recording -JH */
356 g_profstack[g_profstack_ix++].ptype = ptype;
357 g_profstack[g_profstack_ix++].id = id;
359 /* Only record the parent's info */
360 if (g_SAVE_STACK < g_profstack_ix) {
361 if (g_prof_pid == (int)getpid())
362 prof_dump_until(aTHX_ g_profstack_ix);
364 PL_perldb = 0; /* Do not debug the kid. */
368 else { /* Write it to disk now so's not to eat up core */
370 /* Only record the parent's info */
371 if (g_prof_pid == (int)getpid()) {
372 prof_dumpa(aTHX_ ptype, id);
376 PL_perldb = 0; /* Do not debug the kid. */
381 # define defstash PL_defstash
384 /* Counts overhead of prof_mark and extra XS call. */
386 test_time(pTHX_ clock_t *r, clock_t *u, clock_t *s)
389 CV *cv = perl_get_cv("Devel::DProf::NONESUCH_noxs", FALSE);
391 HV *oldstash = PL_curstash;
393 clock_t realtime1, realtime2;
394 U32 ototal = g_total;
395 U32 ostack = g_SAVE_STACK;
396 U32 operldb = PL_perldb;
398 g_SAVE_STACK = 1000000;
399 realtime1 = Times(&t1);
403 /* Disable debugging of perl_call_sv on second pass: */
404 PL_curstash = (k == 0 ? PL_defstash : PL_debstash);
405 PL_perldb = g_default_perldb;
408 g_profstack_ix = 0; /* Do not let the stack grow */
410 /* prof_mark(aTHX_ OP_ENTERSUB); */
412 PUSHMARK(PL_stack_sp);
413 perl_call_sv((SV*)cv, G_SCALAR);
415 /* prof_mark(aTHX_ OP_LEAVESUB); */
418 PL_curstash = oldstash;
419 if (k == 0) { /* Put time with debugging */
420 realtime2 = Times(&t2);
421 *r = realtime2 - realtime1;
422 *u = t2.tms_utime - t1.tms_utime;
423 *s = t2.tms_stime - t1.tms_stime;
425 else { /* Subtract time without debug */
426 realtime1 = Times(&t1);
427 *r -= realtime1 - realtime2;
428 *u -= t1.tms_utime - t2.tms_utime;
429 *s -= t1.tms_stime - t2.tms_stime;
434 g_SAVE_STACK = ostack;
439 prof_recordheader(pTHX)
443 /* g_fp is opened in the BOOT section */
444 PerlIO_printf(g_fp, "#fOrTyTwO\n");
445 PerlIO_printf(g_fp, "$hz=%"IVdf";\n", (IV)DPROF_HZ);
446 PerlIO_printf(g_fp, "$XS_VERSION='DProf %s';\n", XS_VERSION);
447 PerlIO_printf(g_fp, "# All values are given in HZ\n");
448 test_time(aTHX_ &r, &u, &s);
450 "$over_utime=%"IVdf"; $over_stime=%"IVdf"; $over_rtime=%"IVdf";\n",
451 /* The (IV) casts are one possibility:
452 * the Painfully Correct Way would be to
454 (IV)u, (IV)s, (IV)r);
455 PerlIO_printf(g_fp, "$over_tests=10000;\n");
457 g_TIMES_LOCATION = PerlIO_tell(g_fp);
459 /* Pad with whitespace. */
460 /* This should be enough even for very large numbers. */
461 PerlIO_printf(g_fp, "%*s\n", 240 , "");
463 PerlIO_printf(g_fp, "\n");
464 PerlIO_printf(g_fp, "PART2\n");
472 /* g_fp is opened in the BOOT section */
474 /* Now that we know the runtimes, fill them in at the recorded
480 prof_dump_until(aTHX_ g_profstack_ix);
482 PerlIO_seek(g_fp, g_TIMES_LOCATION, SEEK_SET);
483 /* Write into reserved 240 bytes: */
485 "$rrun_utime=%"IVdf"; $rrun_stime=%"IVdf"; $rrun_rtime=%"IVdf";",
486 /* The (IV) casts are one possibility:
487 * the Painfully Correct Way would be to
489 (IV)(g_prof_end.tms_utime-g_prof_start.tms_utime-g_wprof_u),
490 (IV)(g_prof_end.tms_stime-g_prof_start.tms_stime-g_wprof_s),
491 (IV)(g_rprof_end-g_rprof_start-g_wprof_r));
492 PerlIO_printf(g_fp, "\n$total_marks=%"IVdf, (IV)g_total);
500 check_depth(pTHX_ void *foo)
502 U32 need_depth = (U32)foo;
503 if (need_depth != g_depth) {
504 if (need_depth > g_depth) {
505 warn("garbled call depth when profiling");
508 I32 marks = g_depth - need_depth;
510 /* warn("Check_depth: got %d, expected %d\n", g_depth, need_depth); */
512 prof_mark(aTHX_ OP_DIE);
514 g_depth = need_depth;
526 SV *Sub = GvSV(PL_DBsub); /* name of current sub */
528 #ifdef PERL_IMPLICIT_CONTEXT
529 /* profile only the interpreter that loaded us */
532 perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG);
537 HV *oldstash = PL_curstash;
539 DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV(Sub, na));
541 SAVEDESTRUCTOR_X(check_depth, (void*)g_depth);
544 prof_mark(aTHX_ OP_ENTERSUB);
546 perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG);
547 prof_mark(aTHX_ OP_LEAVESUB);
555 #ifdef PERL_IMPLICIT_CONTEXT
559 prof_mark(aTHX_ OP_GOTO);
564 #endif /* for_real */
568 MODULE = Devel::DProf PACKAGE = DB
575 HV *oldstash = PL_curstash;
576 SV *Sub = GvSV(PL_DBsub); /* name of current sub */
577 /* SP -= items; added by xsubpp */
578 DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV(Sub, na));
580 sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */
582 prof_mark(aTHX_ OP_ENTERSUB);
585 PL_curstash = PL_debstash; /* To disable debugging of perl_call_sv */
586 perl_call_sv(Sub, GIMME);
587 PL_curstash = oldstash;
589 prof_mark(aTHX_ OP_LEAVESUB);
591 /* PUTBACK; added by xsubpp */
596 MODULE = Devel::DProf PACKAGE = Devel::DProf
603 /* maybe the process forked--we want only
604 * the parent's profile.
607 #ifdef PERL_IMPLICIT_CONTEXT
610 g_prof_pid == (int)getpid())
612 g_rprof_end = Times(&g_prof_end);
613 DBG_TIMER_NOTIFY("Profiler timer is off.\n");
624 g_TIMES_LOCATION = 42;
625 g_SAVE_STACK = 1<<14;
626 g_profstack_max = 128;
627 #ifdef PERL_IMPLICIT_CONTEXT
631 /* Before we go anywhere make sure we were invoked
632 * properly, else we'll dump core.
635 croak("DProf: run perl with -d to use DProf.\n");
637 /* When we hook up the XS DB::sub we'll be redefining
638 * the DB::sub from the PM file. Turn off warnings
642 I32 warn_tmp = PL_dowarn;
644 newXS("DB::sub", XS_DB_sub, file);
645 newXS("DB::goto", XS_DB_goto, file);
646 PL_dowarn = warn_tmp;
649 sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */
652 char *buffer = getenv("PERL_DPROF_BUFFER");
655 g_SAVE_STACK = atoi(buffer);
658 buffer = getenv("PERL_DPROF_TICKS");
661 g_dprof_ticks = atoi(buffer); /* Used under OS/2 only */
668 if ((g_fp = PerlIO_open("tmon.out", "w")) == NULL)
669 croak("DProf: unable to write tmon.out, errno = %d\n", errno);
671 g_default_perldb = PERLDBf_NONAME | PERLDBf_SUB | PERLDBf_GOTO;
673 g_prof_pid = (int)getpid();
675 New(0, g_profstack, g_profstack_max, PROFANY);
676 prof_recordheader(aTHX);
677 DBG_TIMER_NOTIFY("Profiler timer is on.\n");
678 g_orealtime = g_rprof_start = Times(&g_prof_start);
679 g_otms_utime = g_prof_start.tms_utime;
680 g_otms_stime = g_prof_start.tms_stime;
681 PL_perldb = g_default_perldb;