This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ext/ + -Wall
[perl5.git] / ext / Devel / DProf / DProf.xs
CommitLineData
146174a9 1#define PERL_NO_GET_CONTEXT
583a019e
GS
2#include "EXTERN.h"
3#include "perl.h"
4#include "XSUB.h"
5
7399586d
HS
6/*#define DBG_SUB 1 */
7/*#define DBG_TIMER 1 */
583a019e
GS
8
9#ifdef DBG_SUB
146174a9 10# define DBG_SUB_NOTIFY(A,B) warn(A, B)
583a019e
GS
11#else
12# define DBG_SUB_NOTIFY(A,B) /* nothing */
13#endif
14
15#ifdef DBG_TIMER
146174a9 16# define DBG_TIMER_NOTIFY(A) warn(A)
583a019e
GS
17#else
18# define DBG_TIMER_NOTIFY(A) /* nothing */
19#endif
20
583a019e
GS
21/* HZ == clock ticks per second */
22#ifdef VMS
552e38a9 23# define HZ ((I32)CLK_TCK)
583a019e
GS
24# define DPROF_HZ HZ
25# include <starlet.h> /* prototype for sys$gettim() */
3e4b306a 26# include <lib$routines.h>
146174a9 27# define Times(ptr) (dprof_times(aTHX_ ptr))
583a019e
GS
28#else
29# ifndef HZ
30# ifdef CLK_TCK
552e38a9 31# define HZ ((I32)CLK_TCK)
583a019e
GS
32# else
33# define HZ 60
34# endif
35# endif
36# ifdef OS2 /* times() has significant overhead */
146174a9 37# define Times(ptr) (dprof_times(aTHX_ ptr))
583a019e
GS
38# define INCL_DOSPROFILE
39# define INCL_DOSERRORS
40# include <os2.h>
41# define toLongLong(arg) (*(long long*)&(arg))
146174a9 42# define DPROF_HZ g_dprof_ticks
583a019e
GS
43# else
44# define Times(ptr) (times(ptr))
45# define DPROF_HZ HZ
46# endif
47#endif
48
49XS(XS_Devel__DProf_END); /* used by prof_mark() */
50
583a019e
GS
51/* Everything is built on times(2). See its manpage for a description
52 * of the timings.
53 */
54
583a019e
GS
55union prof_any {
56 clock_t tms_utime; /* cpu time spent in user space */
57 clock_t tms_stime; /* cpu time spent in system */
58 clock_t realtime; /* elapsed real time, in ticks */
59 char *name;
60 U32 id;
61 opcode ptype;
62};
63
64typedef union prof_any PROFANY;
65
146174a9
CB
66typedef struct {
67 U32 dprof_ticks;
68 char* out_file_name; /* output file (defaults to tmon.out) */
69 PerlIO* fp; /* pointer to tmon.out file */
70 long TIMES_LOCATION; /* Where in the file to store the time totals */
71 int SAVE_STACK; /* How much data to buffer until end of run */
72 int prof_pid; /* pid of profiled process */
73 struct tms prof_start;
74 struct tms prof_end;
75 clock_t rprof_start; /* elapsed real time ticks */
76 clock_t rprof_end;
77 clock_t wprof_u;
78 clock_t wprof_s;
79 clock_t wprof_r;
80 clock_t otms_utime;
81 clock_t otms_stime;
82 clock_t orealtime;
83 PROFANY* profstack;
84 int profstack_max;
85 int profstack_ix;
86 HV* cv_hash;
87 U32 total;
88 U32 lastid;
89 U32 default_perldb;
425d70b4 90 UV depth;
146174a9
CB
91#ifdef OS2
92 ULONG frequ;
93 long long start_cnt;
94#endif
95#ifdef PERL_IMPLICIT_CONTEXT
96# define register
97 pTHX;
98# undef register
99#endif
100} prof_state_t;
101
102prof_state_t g_prof_state;
103
104#define g_dprof_ticks g_prof_state.dprof_ticks
105#define g_out_file_name g_prof_state.out_file_name
106#define g_fp g_prof_state.fp
107#define g_TIMES_LOCATION g_prof_state.TIMES_LOCATION
108#define g_SAVE_STACK g_prof_state.SAVE_STACK
109#define g_prof_pid g_prof_state.prof_pid
110#define g_prof_start g_prof_state.prof_start
111#define g_prof_end g_prof_state.prof_end
112#define g_rprof_start g_prof_state.rprof_start
113#define g_rprof_end g_prof_state.rprof_end
114#define g_wprof_u g_prof_state.wprof_u
115#define g_wprof_s g_prof_state.wprof_s
116#define g_wprof_r g_prof_state.wprof_r
117#define g_otms_utime g_prof_state.otms_utime
118#define g_otms_stime g_prof_state.otms_stime
119#define g_orealtime g_prof_state.orealtime
120#define g_profstack g_prof_state.profstack
121#define g_profstack_max g_prof_state.profstack_max
122#define g_profstack_ix g_prof_state.profstack_ix
123#define g_cv_hash g_prof_state.cv_hash
124#define g_total g_prof_state.total
125#define g_lastid g_prof_state.lastid
126#define g_default_perldb g_prof_state.default_perldb
127#define g_depth g_prof_state.depth
128#ifdef PERL_IMPLICIT_CONTEXT
129# define g_THX g_prof_state.aTHX
130#endif
131#ifdef OS2
132# define g_frequ g_prof_state.frequ
133# define g_start_cnt g_prof_state.start_cnt
134#endif
583a019e 135
146174a9
CB
136clock_t
137dprof_times(pTHX_ struct tms *t)
583a019e 138{
146174a9
CB
139#ifdef OS2
140 ULONG rc;
141 QWORD cnt;
cb50131a 142 STRLEN n_a;
146174a9
CB
143
144 if (!g_frequ) {
145 if (CheckOSError(DosTmrQueryFreq(&g_frequ)))
cb50131a 146 croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),n_a));
146174a9
CB
147 else
148 g_frequ = g_frequ/DPROF_HZ; /* count per tick */
149 if (CheckOSError(DosTmrQueryTime(&cnt)))
150 croak("DosTmrQueryTime: %s",
cb50131a 151 SvPV(perl_get_sv("!",TRUE), n_a));
146174a9 152 g_start_cnt = toLongLong(cnt);
583a019e 153 }
146174a9
CB
154
155 if (CheckOSError(DosTmrQueryTime(&cnt)))
cb50131a 156 croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE), n_a));
146174a9
CB
157 t->tms_stime = 0;
158 return (t->tms_utime = (toLongLong(cnt) - g_start_cnt)/g_frequ);
159#else /* !OS2 */
160# ifdef VMS
161 clock_t retval;
162 /* Get wall time and convert to 10 ms intervals to
163 * produce the return value dprof expects */
164# if defined(__DECC) && defined (__ALPHA)
165# include <ints.h>
166 uint64 vmstime;
167 _ckvmssts(sys$gettim(&vmstime));
168 vmstime /= 100000;
169 retval = vmstime & 0x7fffffff;
170# else
171 /* (Older hw or ccs don't have an atomic 64-bit type, so we
172 * juggle 32-bit ints (and a float) to produce a time_t result
173 * with minimal loss of information.) */
174 long int vmstime[2],remainder,divisor = 100000;
175 _ckvmssts(sys$gettim((unsigned long int *)vmstime));
176 vmstime[1] &= 0x7fff; /* prevent overflow in EDIV */
177 _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder));
178# endif
179 /* Fill in the struct tms using the CRTL routine . . .*/
180 times((tbuffer_t *)t);
181 return (clock_t) retval;
182# else /* !VMS && !OS2 */
183 return times(t);
184# endif
185#endif
186}
583a019e
GS
187
188static void
146174a9 189prof_dumpa(pTHX_ opcode ptype, U32 id)
583a019e 190{
146174a9
CB
191 if (ptype == OP_LEAVESUB) {
192 PerlIO_printf(g_fp,"- %"UVxf"\n", (UV)id);
193 }
194 else if(ptype == OP_ENTERSUB) {
195 PerlIO_printf(g_fp,"+ %"UVxf"\n", (UV)id);
196 }
197 else if(ptype == OP_GOTO) {
198 PerlIO_printf(g_fp,"* %"UVxf"\n", (UV)id);
199 }
200 else if(ptype == OP_DIE) {
201 PerlIO_printf(g_fp,"/ %"UVxf"\n", (UV)id);
202 }
203 else {
204 PerlIO_printf(g_fp,"Profiler unknown prof code %d\n", ptype);
583a019e
GS
205 }
206}
207
208static void
146174a9 209prof_dumps(pTHX_ U32 id, char *pname, char *gname)
583a019e 210{
146174a9 211 PerlIO_printf(g_fp,"& %"UVxf" %s %s\n", (UV)id, pname, gname);
583a019e
GS
212}
213
583a019e 214static void
146174a9 215prof_dumpt(pTHX_ long tms_utime, long tms_stime, long realtime)
583a019e 216{
146174a9 217 PerlIO_printf(g_fp,"@ %ld %ld %ld\n", tms_utime, tms_stime, realtime);
583a019e
GS
218}
219
220static void
146174a9 221prof_dump_until(pTHX_ long ix)
583a019e
GS
222{
223 long base = 0;
224 struct tms t1, t2;
225 clock_t realtime1, realtime2;
226
227 realtime1 = Times(&t1);
228
146174a9
CB
229 while (base < ix) {
230 opcode ptype = g_profstack[base++].ptype;
583a019e 231 if (ptype == OP_TIME) {
146174a9
CB
232 long tms_utime = g_profstack[base++].tms_utime;
233 long tms_stime = g_profstack[base++].tms_stime;
234 long realtime = g_profstack[base++].realtime;
235
236 prof_dumpt(aTHX_ tms_utime, tms_stime, realtime);
237 }
238 else if (ptype == OP_GV) {
239 U32 id = g_profstack[base++].id;
240 char *pname = g_profstack[base++].name;
241 char *gname = g_profstack[base++].name;
242
243 prof_dumps(aTHX_ id, pname, gname);
244 }
245 else {
246 U32 id = g_profstack[base++].id;
247 prof_dumpa(aTHX_ ptype, id);
583a019e
GS
248 }
249 }
146174a9 250 PerlIO_flush(g_fp);
583a019e
GS
251 realtime2 = Times(&t2);
252 if (realtime2 != realtime1 || t1.tms_utime != t2.tms_utime
253 || t1.tms_stime != t2.tms_stime) {
146174a9
CB
254 g_wprof_r += realtime2 - realtime1;
255 g_wprof_u += t2.tms_utime - t1.tms_utime;
256 g_wprof_s += t2.tms_stime - t1.tms_stime;
257
258 PerlIO_printf(g_fp,"+ & Devel::DProf::write\n");
259 PerlIO_printf(g_fp,"@ %"IVdf" %"IVdf" %"IVdf"\n",
260 /* The (IV) casts are one possibility:
261 * the Painfully Correct Way would be to
262 * have Clock_t_f. */
263 (IV)(t2.tms_utime - t1.tms_utime),
264 (IV)(t2.tms_stime - t1.tms_stime),
265 (IV)(realtime2 - realtime1));
266 PerlIO_printf(g_fp,"- & Devel::DProf::write\n");
267 g_otms_utime = t2.tms_utime;
268 g_otms_stime = t2.tms_stime;
269 g_orealtime = realtime2;
270 PerlIO_flush(g_fp);
583a019e
GS
271 }
272}
273
583a019e 274static void
146174a9 275prof_mark(pTHX_ opcode ptype)
583a019e 276{
146174a9
CB
277 struct tms t;
278 clock_t realtime, rdelta, udelta, sdelta;
146174a9
CB
279 U32 id;
280 SV *Sub = GvSV(PL_DBsub); /* name of current sub */
281
282 if (g_SAVE_STACK) {
283 if (g_profstack_ix + 5 > g_profstack_max) {
284 g_profstack_max = g_profstack_max * 3 / 2;
285 Renew(g_profstack, g_profstack_max, PROFANY);
286 }
287 }
583a019e 288
146174a9
CB
289 realtime = Times(&t);
290 rdelta = realtime - g_orealtime;
291 udelta = t.tms_utime - g_otms_utime;
292 sdelta = t.tms_stime - g_otms_stime;
293 if (rdelta || udelta || sdelta) {
294 if (g_SAVE_STACK) {
295 g_profstack[g_profstack_ix++].ptype = OP_TIME;
296 g_profstack[g_profstack_ix++].tms_utime = udelta;
297 g_profstack[g_profstack_ix++].tms_stime = sdelta;
298 g_profstack[g_profstack_ix++].realtime = rdelta;
299 }
300 else { /* Write it to disk now so's not to eat up core */
301 if (g_prof_pid == (int)getpid()) {
302 prof_dumpt(aTHX_ udelta, sdelta, rdelta);
303 PerlIO_flush(g_fp);
583a019e 304 }
583a019e 305 }
146174a9
CB
306 g_orealtime = realtime;
307 g_otms_stime = t.tms_stime;
308 g_otms_utime = t.tms_utime;
309 }
583a019e 310
146174a9
CB
311 {
312 SV **svp;
313 char *gname, *pname;
314 CV *cv;
315
316 cv = INT2PTR(CV*,SvIVX(Sub));
317 svp = hv_fetch(g_cv_hash, (char*)&cv, sizeof(CV*), TRUE);
318 if (!SvOK(*svp)) {
319 GV *gv = CvGV(cv);
320
321 sv_setiv(*svp, id = ++g_lastid);
322 pname = ((GvSTASH(gv) && HvNAME(GvSTASH(gv)))
323 ? HvNAME(GvSTASH(gv))
324 : "(null)");
325 gname = GvNAME(gv);
326 if (CvXSUB(cv) == XS_Devel__DProf_END)
327 return;
328 if (g_SAVE_STACK) { /* Store it for later recording -JH */
329 g_profstack[g_profstack_ix++].ptype = OP_GV;
330 g_profstack[g_profstack_ix++].id = id;
331 g_profstack[g_profstack_ix++].name = pname;
332 g_profstack[g_profstack_ix++].name = gname;
333 }
334 else { /* Write it to disk now so's not to eat up core */
335 /* Only record the parent's info */
336 if (g_prof_pid == (int)getpid()) {
337 prof_dumps(aTHX_ id, pname, gname);
338 PerlIO_flush(g_fp);
583a019e 339 }
146174a9
CB
340 else
341 PL_perldb = 0; /* Do not debug the kid. */
583a019e
GS
342 }
343 }
146174a9
CB
344 else {
345 id = SvIV(*svp);
346 }
347 }
583a019e 348
146174a9
CB
349 g_total++;
350 if (g_SAVE_STACK) { /* Store it for later recording -JH */
351 g_profstack[g_profstack_ix++].ptype = ptype;
352 g_profstack[g_profstack_ix++].id = id;
353
354 /* Only record the parent's info */
355 if (g_SAVE_STACK < g_profstack_ix) {
356 if (g_prof_pid == (int)getpid())
357 prof_dump_until(aTHX_ g_profstack_ix);
358 else
359 PL_perldb = 0; /* Do not debug the kid. */
360 g_profstack_ix = 0;
361 }
362 }
363 else { /* Write it to disk now so's not to eat up core */
583a019e 364
146174a9
CB
365 /* Only record the parent's info */
366 if (g_prof_pid == (int)getpid()) {
367 prof_dumpa(aTHX_ ptype, id);
368 PerlIO_flush(g_fp);
369 }
370 else
371 PL_perldb = 0; /* Do not debug the kid. */
372 }
583a019e
GS
373}
374
583a019e
GS
375#ifdef PL_NEEDED
376# define defstash PL_defstash
377#endif
378
379/* Counts overhead of prof_mark and extra XS call. */
380static void
146174a9 381test_time(pTHX_ clock_t *r, clock_t *u, clock_t *s)
583a019e 382{
583a019e
GS
383 CV *cv = perl_get_cv("Devel::DProf::NONESUCH_noxs", FALSE);
384 int i, j, k = 0;
146174a9 385 HV *oldstash = PL_curstash;
583a019e 386 struct tms t1, t2;
9c5ffd7c 387 clock_t realtime1 = 0, realtime2 = 0;
146174a9
CB
388 U32 ototal = g_total;
389 U32 ostack = g_SAVE_STACK;
390 U32 operldb = PL_perldb;
583a019e 391
146174a9 392 g_SAVE_STACK = 1000000;
583a019e
GS
393 realtime1 = Times(&t1);
394
395 while (k < 2) {
396 i = 0;
397 /* Disable debugging of perl_call_sv on second pass: */
146174a9
CB
398 PL_curstash = (k == 0 ? PL_defstash : PL_debstash);
399 PL_perldb = g_default_perldb;
583a019e
GS
400 while (++i <= 100) {
401 j = 0;
146174a9 402 g_profstack_ix = 0; /* Do not let the stack grow */
583a019e 403 while (++j <= 100) {
146174a9 404/* prof_mark(aTHX_ OP_ENTERSUB); */
583a019e 405
146174a9
CB
406 PUSHMARK(PL_stack_sp);
407 perl_call_sv((SV*)cv, G_SCALAR);
408 PL_stack_sp--;
409/* prof_mark(aTHX_ OP_LEAVESUB); */
583a019e
GS
410 }
411 }
146174a9 412 PL_curstash = oldstash;
583a019e
GS
413 if (k == 0) { /* Put time with debugging */
414 realtime2 = Times(&t2);
415 *r = realtime2 - realtime1;
416 *u = t2.tms_utime - t1.tms_utime;
417 *s = t2.tms_stime - t1.tms_stime;
146174a9
CB
418 }
419 else { /* Subtract time without debug */
583a019e
GS
420 realtime1 = Times(&t1);
421 *r -= realtime1 - realtime2;
422 *u -= t1.tms_utime - t2.tms_utime;
423 *s -= t1.tms_stime - t2.tms_stime;
424 }
425 k++;
426 }
146174a9
CB
427 g_total = ototal;
428 g_SAVE_STACK = ostack;
429 PL_perldb = operldb;
583a019e
GS
430}
431
432static void
146174a9 433prof_recordheader(pTHX)
583a019e 434{
146174a9
CB
435 clock_t r, u, s;
436
437 /* g_fp is opened in the BOOT section */
438 PerlIO_printf(g_fp, "#fOrTyTwO\n");
439 PerlIO_printf(g_fp, "$hz=%"IVdf";\n", (IV)DPROF_HZ);
440 PerlIO_printf(g_fp, "$XS_VERSION='DProf %s';\n", XS_VERSION);
441 PerlIO_printf(g_fp, "# All values are given in HZ\n");
442 test_time(aTHX_ &r, &u, &s);
443 PerlIO_printf(g_fp,
444 "$over_utime=%"IVdf"; $over_stime=%"IVdf"; $over_rtime=%"IVdf";\n",
445 /* The (IV) casts are one possibility:
446 * the Painfully Correct Way would be to
447 * have Clock_t_f. */
448 (IV)u, (IV)s, (IV)r);
449 PerlIO_printf(g_fp, "$over_tests=10000;\n");
450
451 g_TIMES_LOCATION = PerlIO_tell(g_fp);
452
453 /* Pad with whitespace. */
454 /* This should be enough even for very large numbers. */
455 PerlIO_printf(g_fp, "%*s\n", 240 , "");
456
457 PerlIO_printf(g_fp, "\n");
458 PerlIO_printf(g_fp, "PART2\n");
459
460 PerlIO_flush(g_fp);
583a019e
GS
461}
462
463static void
146174a9 464prof_record(pTHX)
583a019e 465{
146174a9
CB
466 /* g_fp is opened in the BOOT section */
467
468 /* Now that we know the runtimes, fill them in at the recorded
469 location -JH */
583a019e 470
146174a9
CB
471 if (g_SAVE_STACK) {
472 prof_dump_until(aTHX_ g_profstack_ix);
473 }
474 PerlIO_seek(g_fp, g_TIMES_LOCATION, SEEK_SET);
475 /* Write into reserved 240 bytes: */
476 PerlIO_printf(g_fp,
477 "$rrun_utime=%"IVdf"; $rrun_stime=%"IVdf"; $rrun_rtime=%"IVdf";",
478 /* The (IV) casts are one possibility:
479 * the Painfully Correct Way would be to
480 * have Clock_t_f. */
481 (IV)(g_prof_end.tms_utime-g_prof_start.tms_utime-g_wprof_u),
482 (IV)(g_prof_end.tms_stime-g_prof_start.tms_stime-g_wprof_s),
483 (IV)(g_rprof_end-g_rprof_start-g_wprof_r));
484 PerlIO_printf(g_fp, "\n$total_marks=%"IVdf, (IV)g_total);
583a019e 485
146174a9 486 PerlIO_close(g_fp);
583a019e
GS
487}
488
489#define NONESUCH()
490
583a019e 491static void
d7b9cf63 492check_depth(pTHX_ void *foo)
583a019e 493{
4b19af01 494 U32 need_depth = PTR2UV(foo);
146174a9
CB
495 if (need_depth != g_depth) {
496 if (need_depth > g_depth) {
583a019e 497 warn("garbled call depth when profiling");
146174a9
CB
498 }
499 else {
425d70b4 500 IV marks = g_depth - need_depth;
583a019e 501
146174a9 502/* warn("Check_depth: got %d, expected %d\n", g_depth, need_depth); */
583a019e 503 while (marks--) {
146174a9 504 prof_mark(aTHX_ OP_DIE);
583a019e 505 }
146174a9 506 g_depth = need_depth;
583a019e
GS
507 }
508 }
509}
510
511#define for_real
512#ifdef for_real
513
514XS(XS_DB_sub)
515{
c6c619a9 516 dMARK;
146174a9
CB
517 dORIGMARK;
518 SV *Sub = GvSV(PL_DBsub); /* name of current sub */
519
520#ifdef PERL_IMPLICIT_CONTEXT
521 /* profile only the interpreter that loaded us */
522 if (g_THX != aTHX) {
523 PUSHMARK(ORIGMARK);
524 perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG);
525 }
526 else
527#endif
528 {
529 HV *oldstash = PL_curstash;
583a019e 530
cb50131a 531 DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub));
583a019e 532
a6f8e609 533 SAVEDESTRUCTOR_X(check_depth, INT2PTR(void*,g_depth));
146174a9 534 g_depth++;
583a019e 535
146174a9
CB
536 prof_mark(aTHX_ OP_ENTERSUB);
537 PUSHMARK(ORIGMARK);
538 perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG);
8063af02 539 PL_curstash = oldstash;
146174a9
CB
540 prof_mark(aTHX_ OP_LEAVESUB);
541 g_depth--;
542 }
543 return;
583a019e
GS
544}
545
546XS(XS_DB_goto)
547{
146174a9
CB
548#ifdef PERL_IMPLICIT_CONTEXT
549 if (g_THX == aTHX)
550#endif
551 {
552 prof_mark(aTHX_ OP_GOTO);
583a019e 553 return;
146174a9 554 }
583a019e
GS
555}
556
557#endif /* for_real */
558
559#ifdef testing
560
561 MODULE = Devel::DProf PACKAGE = DB
562
563 void
564 sub(...)
146174a9
CB
565 PPCODE:
566 {
583a019e 567 dORIGMARK;
146174a9
CB
568 HV *oldstash = PL_curstash;
569 SV *Sub = GvSV(PL_DBsub); /* name of current sub */
583a019e 570 /* SP -= items; added by xsubpp */
cb50131a 571 DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub));
583a019e 572
146174a9 573 sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */
583a019e 574
146174a9
CB
575 prof_mark(aTHX_ OP_ENTERSUB);
576 PUSHMARK(ORIGMARK);
583a019e 577
146174a9
CB
578 PL_curstash = PL_debstash; /* To disable debugging of perl_call_sv */
579 perl_call_sv(Sub, GIMME);
580 PL_curstash = oldstash;
583a019e 581
146174a9 582 prof_mark(aTHX_ OP_LEAVESUB);
583a019e
GS
583 SPAGAIN;
584 /* PUTBACK; added by xsubpp */
146174a9 585 }
583a019e
GS
586
587#endif /* testing */
588
589MODULE = Devel::DProf PACKAGE = Devel::DProf
590
591void
592END()
146174a9
CB
593PPCODE:
594 {
595 if (PL_DBsub) {
596 /* maybe the process forked--we want only
597 * the parent's profile.
598 */
599 if (
600#ifdef PERL_IMPLICIT_CONTEXT
601 g_THX == aTHX &&
602#endif
603 g_prof_pid == (int)getpid())
604 {
605 g_rprof_end = Times(&g_prof_end);
606 DBG_TIMER_NOTIFY("Profiler timer is off.\n");
607 prof_record(aTHX);
608 }
609 }
610 }
583a019e
GS
611
612void
613NONESUCH()
614
615BOOT:
146174a9
CB
616 {
617 g_TIMES_LOCATION = 42;
618 g_SAVE_STACK = 1<<14;
619 g_profstack_max = 128;
620#ifdef PERL_IMPLICIT_CONTEXT
621 g_THX = aTHX;
622#endif
623
583a019e
GS
624 /* Before we go anywhere make sure we were invoked
625 * properly, else we'll dump core.
626 */
146174a9
CB
627 if (!PL_DBsub)
628 croak("DProf: run perl with -d to use DProf.\n");
583a019e
GS
629
630 /* When we hook up the XS DB::sub we'll be redefining
631 * the DB::sub from the PM file. Turn off warnings
632 * while we do this.
633 */
634 {
146174a9
CB
635 I32 warn_tmp = PL_dowarn;
636 PL_dowarn = 0;
637 newXS("DB::sub", XS_DB_sub, file);
638 newXS("DB::goto", XS_DB_goto, file);
639 PL_dowarn = warn_tmp;
583a019e
GS
640 }
641
146174a9 642 sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */
583a019e
GS
643
644 {
645 char *buffer = getenv("PERL_DPROF_BUFFER");
646
647 if (buffer) {
146174a9 648 g_SAVE_STACK = atoi(buffer);
583a019e
GS
649 }
650
651 buffer = getenv("PERL_DPROF_TICKS");
652
653 if (buffer) {
146174a9
CB
654 g_dprof_ticks = atoi(buffer); /* Used under OS/2 only */
655 }
656 else {
657 g_dprof_ticks = HZ;
583a019e 658 }
583a019e 659
146174a9
CB
660 buffer = getenv("PERL_DPROF_OUT_FILE_NAME");
661 g_out_file_name = savepv(buffer ? buffer : "tmon.out");
662 }
583a019e 663
146174a9
CB
664 if ((g_fp = PerlIO_open(g_out_file_name, "w")) == NULL)
665 croak("DProf: unable to write '%s', errno = %d\n",
666 g_out_file_name, errno);
583a019e 667
146174a9
CB
668 g_default_perldb = PERLDBf_NONAME | PERLDBf_SUB | PERLDBf_GOTO;
669 g_cv_hash = newHV();
670 g_prof_pid = (int)getpid();
583a019e 671
146174a9
CB
672 New(0, g_profstack, g_profstack_max, PROFANY);
673 prof_recordheader(aTHX);
583a019e 674 DBG_TIMER_NOTIFY("Profiler timer is on.\n");
146174a9
CB
675 g_orealtime = g_rprof_start = Times(&g_prof_start);
676 g_otms_utime = g_prof_start.tms_utime;
677 g_otms_stime = g_prof_start.tms_stime;
678 PL_perldb = g_default_perldb;
679 }