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
1 #define PERL_NO_GET_CONTEXT
2 #include "EXTERN.h"
3 #include "perl.h"
4 #include "XSUB.h"
5
6 /*#define DBG_SUB 1      */
7 /*#define DBG_TIMER 1    */
8
9 #ifdef DBG_SUB
10 #  define DBG_SUB_NOTIFY(A,B) warn(A, B)
11 #else
12 #  define DBG_SUB_NOTIFY(A,B)  /* nothing */
13 #endif
14
15 #ifdef DBG_TIMER
16 #  define DBG_TIMER_NOTIFY(A) warn(A)
17 #else
18 #  define DBG_TIMER_NOTIFY(A)  /* nothing */
19 #endif
20
21 /* HZ == clock ticks per second */
22 #ifdef VMS
23 #  define HZ ((I32)CLK_TCK)
24 #  define DPROF_HZ HZ
25 #  include <starlet.h>  /* prototype for sys$gettim() */
26 #  include <lib$routines.h>
27 #  define Times(ptr) (dprof_times(aTHX_ ptr))
28 #else
29 #  ifndef HZ
30 #    ifdef CLK_TCK
31 #      define HZ ((I32)CLK_TCK)
32 #    else
33 #      define HZ 60
34 #    endif
35 #  endif
36 #  ifdef OS2                            /* times() has significant overhead */
37 #    define Times(ptr) (dprof_times(aTHX_ ptr))
38 #    define INCL_DOSPROFILE
39 #    define INCL_DOSERRORS
40 #    include <os2.h>
41 #    define toLongLong(arg) (*(long long*)&(arg))
42 #    define DPROF_HZ g_dprof_ticks
43 #  else
44 #    define Times(ptr) (times(ptr))
45 #    define DPROF_HZ HZ
46 #  endif 
47 #endif
48
49 XS(XS_Devel__DProf_END);        /* used by prof_mark() */
50
51 /* Everything is built on times(2).  See its manpage for a description
52  * of the timings.
53  */
54
55 union 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
64 typedef union prof_any PROFANY;
65
66 typedef 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;
90     UV          depth;
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
102 prof_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
135
136 clock_t
137 dprof_times(pTHX_ struct tms *t)
138 {
139 #ifdef OS2
140     ULONG rc;
141     QWORD cnt;
142     STRLEN n_a;
143     
144     if (!g_frequ) {
145         if (CheckOSError(DosTmrQueryFreq(&g_frequ)))
146             croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),n_a));
147         else
148             g_frequ = g_frequ/DPROF_HZ; /* count per tick */
149         if (CheckOSError(DosTmrQueryTime(&cnt)))
150             croak("DosTmrQueryTime: %s",
151                   SvPV(perl_get_sv("!",TRUE), n_a));
152         g_start_cnt = toLongLong(cnt);
153     }
154
155     if (CheckOSError(DosTmrQueryTime(&cnt)))
156             croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE), n_a));
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 }
187
188 static void
189 prof_dumpa(pTHX_ opcode ptype, U32 id)
190 {
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);
205     }
206 }   
207
208 static void
209 prof_dumps(pTHX_ U32 id, char *pname, char *gname)
210 {
211     PerlIO_printf(g_fp,"& %"UVxf" %s %s\n", (UV)id, pname, gname);
212 }   
213
214 static void
215 prof_dumpt(pTHX_ long tms_utime, long tms_stime, long realtime)
216 {
217     PerlIO_printf(g_fp,"@ %ld %ld %ld\n", tms_utime, tms_stime, realtime);
218 }   
219
220 static void
221 prof_dump_until(pTHX_ long ix)
222 {
223     long base = 0;
224     struct tms t1, t2;
225     clock_t realtime1, realtime2;
226
227     realtime1 = Times(&t1);
228
229     while (base < ix) {
230         opcode ptype = g_profstack[base++].ptype;
231         if (ptype == OP_TIME) {
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);
248         }
249     }
250     PerlIO_flush(g_fp);
251     realtime2 = Times(&t2);
252     if (realtime2 != realtime1 || t1.tms_utime != t2.tms_utime
253         || t1.tms_stime != t2.tms_stime) {
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);
271     }
272 }
273
274 static void
275 prof_mark(pTHX_ opcode ptype)
276 {
277     struct tms t;
278     clock_t realtime, rdelta, udelta, sdelta;
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     }
288
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);
304             }
305         }
306         g_orealtime = realtime;
307         g_otms_stime = t.tms_stime;
308         g_otms_utime = t.tms_utime;
309     }
310
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);
339                 }
340                 else
341                     PL_perldb = 0;              /* Do not debug the kid. */
342             }
343         }
344         else {
345             id = SvIV(*svp);
346         }
347     }
348
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 */
364
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     }
373 }
374
375 #ifdef PL_NEEDED
376 #  define defstash PL_defstash
377 #endif
378
379 /* Counts overhead of prof_mark and extra XS call. */
380 static void
381 test_time(pTHX_ clock_t *r, clock_t *u, clock_t *s)
382 {
383     CV *cv = perl_get_cv("Devel::DProf::NONESUCH_noxs", FALSE);
384     int i, j, k = 0;
385     HV *oldstash = PL_curstash;
386     struct tms t1, t2;
387     clock_t realtime1 = 0, realtime2 = 0;
388     U32 ototal = g_total;
389     U32 ostack = g_SAVE_STACK;
390     U32 operldb = PL_perldb;
391
392     g_SAVE_STACK = 1000000;
393     realtime1 = Times(&t1);
394     
395     while (k < 2) {
396         i = 0;
397             /* Disable debugging of perl_call_sv on second pass: */
398         PL_curstash = (k == 0 ? PL_defstash : PL_debstash);
399         PL_perldb = g_default_perldb;
400         while (++i <= 100) {
401             j = 0;
402             g_profstack_ix = 0;         /* Do not let the stack grow */
403             while (++j <= 100) {
404 /*              prof_mark(aTHX_ OP_ENTERSUB); */
405
406                 PUSHMARK(PL_stack_sp);
407                 perl_call_sv((SV*)cv, G_SCALAR);
408                 PL_stack_sp--;
409 /*              prof_mark(aTHX_ OP_LEAVESUB); */
410             }
411         }
412         PL_curstash = oldstash;
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;
418         }
419         else {                          /* Subtract time without debug */
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     }
427     g_total = ototal;
428     g_SAVE_STACK = ostack;
429     PL_perldb = operldb;
430 }
431
432 static void
433 prof_recordheader(pTHX)
434 {
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);
461 }
462
463 static void
464 prof_record(pTHX)
465 {
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 */
470
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);
485     
486     PerlIO_close(g_fp);
487 }
488
489 #define NONESUCH()
490
491 static void
492 check_depth(pTHX_ void *foo)
493 {
494     U32 need_depth = PTR2UV(foo);
495     if (need_depth != g_depth) {
496         if (need_depth > g_depth) {
497             warn("garbled call depth when profiling");
498         }
499         else {
500             IV marks = g_depth - need_depth;
501
502 /*          warn("Check_depth: got %d, expected %d\n", g_depth, need_depth); */
503             while (marks--) {
504                 prof_mark(aTHX_ OP_DIE);
505             }
506             g_depth = need_depth;
507         }
508     }
509 }
510
511 #define for_real
512 #ifdef for_real
513
514 XS(XS_DB_sub)
515 {
516     dMARK;
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;
530
531         DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub));
532
533         SAVEDESTRUCTOR_X(check_depth, INT2PTR(void*,g_depth));
534         g_depth++;
535
536         prof_mark(aTHX_ OP_ENTERSUB);
537         PUSHMARK(ORIGMARK);
538         perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG);
539         PL_curstash = oldstash;
540         prof_mark(aTHX_ OP_LEAVESUB);
541         g_depth--;
542     }
543     return;
544 }
545
546 XS(XS_DB_goto)
547 {
548 #ifdef PERL_IMPLICIT_CONTEXT
549     if (g_THX == aTHX)
550 #endif
551     {
552         prof_mark(aTHX_ OP_GOTO);
553         return;
554     }
555 }
556
557 #endif /* for_real */
558
559 #ifdef testing
560
561         MODULE = Devel::DProf           PACKAGE = DB
562
563         void
564         sub(...)
565         PPCODE:
566             {
567                 dORIGMARK;
568                 HV *oldstash = PL_curstash;
569                 SV *Sub = GvSV(PL_DBsub);       /* name of current sub */
570                 /* SP -= items;  added by xsubpp */
571                 DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub));
572
573                 sv_setiv(PL_DBsingle, 0);       /* disable DB single-stepping */
574
575                 prof_mark(aTHX_ OP_ENTERSUB);
576                 PUSHMARK(ORIGMARK);
577
578                 PL_curstash = PL_debstash;      /* To disable debugging of perl_call_sv */
579                 perl_call_sv(Sub, GIMME);
580                 PL_curstash = oldstash;
581
582                 prof_mark(aTHX_ OP_LEAVESUB);
583                 SPAGAIN;
584                 /* PUTBACK;  added by xsubpp */
585             }
586
587 #endif /* testing */
588
589 MODULE = Devel::DProf           PACKAGE = Devel::DProf
590
591 void
592 END()
593 PPCODE:
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     }
611
612 void
613 NONESUCH()
614
615 BOOT:
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
624         /* Before we go anywhere make sure we were invoked
625          * properly, else we'll dump core.
626          */
627         if (!PL_DBsub)
628             croak("DProf: run perl with -d to use DProf.\n");
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         {
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;
640         }
641
642         sv_setiv(PL_DBsingle, 0);       /* disable DB single-stepping */
643
644         {
645             char *buffer = getenv("PERL_DPROF_BUFFER");
646
647             if (buffer) {
648                 g_SAVE_STACK = atoi(buffer);
649             }
650
651             buffer = getenv("PERL_DPROF_TICKS");
652
653             if (buffer) {
654                 g_dprof_ticks = atoi(buffer); /* Used under OS/2 only */
655             }
656             else {
657                 g_dprof_ticks = HZ;
658             }
659
660             buffer = getenv("PERL_DPROF_OUT_FILE_NAME");
661             g_out_file_name = savepv(buffer ? buffer : "tmon.out");
662         }
663
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);
667
668         g_default_perldb = PERLDBf_NONAME | PERLDBf_SUB | PERLDBf_GOTO;
669         g_cv_hash = newHV();
670         g_prof_pid = (int)getpid();
671
672         New(0, g_profstack, g_profstack_max, PROFANY);
673         prof_recordheader(aTHX);
674         DBG_TIMER_NOTIFY("Profiler timer is on.\n");
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     }