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