ext/Devel/DProf/DProf.xs

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