ext/Devel/DProf/DProf.xs

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