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