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(Sub, na));
 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(Sub, na));
 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     }